packages feed

Cabal 3.6.3.0 → 3.16.1.0

raw patch · 295 files changed

Files

Cabal.cabal view
@@ -1,8 +1,8 @@-cabal-version: >=1.10+cabal-version: 3.6 name:          Cabal-version:       3.6.3.0-copyright:     2003-2021, Cabal Development Team (see AUTHORS file)-license:       BSD3+version:       3.16.1.0+copyright:     2003-2025, Cabal Development Team (see AUTHORS file)+license:       BSD-3-Clause license-file:  LICENSE author:        Cabal Development Team <cabal-devel@haskell.org> maintainer:    cabal-devel@haskell.org@@ -21,7 +21,7 @@ -- If we use a new Cabal feature, this needs to be changed to Custom so -- we can bootstrap. -extra-source-files:+extra-doc-files:   README.md ChangeLog.md  source-repository head@@ -29,56 +29,55 @@   location: https://github.com/haskell/cabal/   subdir:   Cabal -flag bundled-binary-generic+flag git-rev+  description: include Git revision hash in version   default: False+  manual: True  library   default-language: Haskell2010   hs-source-dirs: src    build-depends:-    array      >= 0.4.0.1  && < 0.6,-    base       >= 4.6      && < 5,-    bytestring >= 0.10.0.0 && < 0.12,-    containers >= 0.5.0.0  && < 0.7,-    deepseq    >= 1.3.0.1  && < 1.5,-    directory  >= 1.2      && < 1.4,-    filepath   >= 1.3.0.1  && < 1.5,-    pretty     >= 1.1.1    && < 1.2,-    process    >= 1.1.0.2  && < 1.7,-    time       >= 1.4.0.1  && < 1.13--  if flag(bundled-binary-generic)-    build-depends: binary >= 0.5.1.1 && < 0.7-  else-    build-depends: binary >= 0.7 && < 0.9+    , Cabal-syntax ^>= 3.16.1.0+    , array      >= 0.4.0.1  && < 0.6+    , base       >= 4.13     && < 5+    , bytestring >= 0.10.0.0 && < 0.13+    , containers >= 0.5.0.0  && < 0.9+    , deepseq    >= 1.3.0.1  && < 1.7+    , 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.16    if os(windows)-    build-depends: Win32 >= 2.3.0.0 && < 2.13+    build-depends:+      , Win32 >= 2.3.0.0 && < 2.15   else-    build-depends: unix  >= 2.6.0.0 && < 2.8--  ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates-  if impl(ghc >= 8.0)-    ghc-options: -Wcompat -Wnoncanonical-monad-instances+    build-depends:+      , unix  >= 2.8.6.0 && < 2.9 -    if impl(ghc <8.8)-      ghc-options: -Wnoncanonical-monadfail-instances+  if flag(git-rev)+    build-depends:+      , githash ^>= 0.1.7.0+    cpp-options: -DGIT_REV -  if !impl(ghc >= 8.0)-    -- at least one of lib:Cabal's dependency (i.e. `parsec`)-    -- already depends on `fail` and `semigroups` transitively-    build-depends: fail == 4.9.*, semigroups >= 0.18.3 && < 0.21+  ghc-options:+    -Wall+    -fno-ignore-asserts+    -Wtabs+    -Wincomplete-uni-patterns+    -Wincomplete-record-updates+    -Wno-unticked-promoted-constructors -  if !impl(ghc >= 7.10)-    build-depends: void >= 0.7.3 && < 0.8+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wnoncanonical-monad-instances -  if !impl(ghc >= 7.8)-    -- semigroups depends on tagged.-    build-depends:  tagged >=0.8.6 && <0.9+  if impl(ghc >= 8.0) && impl(ghc < 8.8)+    ghc-options: -Wnoncanonical-monadfail-instances    exposed-modules:-    Distribution.Backpack     Distribution.Backpack.Configure     Distribution.Backpack.ComponentsGraph     Distribution.Backpack.ConfiguredComponent@@ -88,71 +87,54 @@     Distribution.Backpack.ModSubst     Distribution.Backpack.ModuleShape     Distribution.Backpack.PreModuleShape-    Distribution.CabalSpecVersion     Distribution.Utils.IOData-    Distribution.Utils.Path     Distribution.Utils.LogProgress     Distribution.Utils.MapAccum-    Distribution.Utils.MD5-    Distribution.Utils.Structured     Distribution.Compat.CreatePipe     Distribution.Compat.Directory     Distribution.Compat.Environment-    Distribution.Compat.Exception     Distribution.Compat.FilePath-    Distribution.Compat.Graph     Distribution.Compat.Internal.TempFile-    Distribution.Compat.Newtype-    Distribution.Compat.NonEmptySet     Distribution.Compat.ResponseFile     Distribution.Compat.Prelude.Internal     Distribution.Compat.Process-    Distribution.Compat.Semigroup     Distribution.Compat.Stack     Distribution.Compat.Time-    Distribution.Compat.Typeable-    Distribution.Compat.DList-    Distribution.Compiler-    Distribution.InstalledPackageInfo-    Distribution.Types.AbiDependency-    Distribution.Types.ExposedModule-    Distribution.Types.InstalledPackageInfo-    Distribution.Types.InstalledPackageInfo.FieldGrammar-    Distribution.License     Distribution.Make-    Distribution.ModuleName-    Distribution.Package-    Distribution.PackageDescription     Distribution.PackageDescription.Check-    Distribution.PackageDescription.Configuration-    Distribution.PackageDescription.PrettyPrint-    Distribution.PackageDescription.Utils     Distribution.ReadE     Distribution.Simple     Distribution.Simple.Bench     Distribution.Simple.Build+    Distribution.Simple.Build.Inputs     Distribution.Simple.Build.Macros+    Distribution.Simple.Build.PackageInfoModule     Distribution.Simple.Build.PathsModule     Distribution.Simple.BuildPaths     Distribution.Simple.BuildTarget     Distribution.Simple.BuildToolDepends+    Distribution.Simple.BuildWay     Distribution.Simple.CCompiler     Distribution.Simple.Command     Distribution.Simple.Compiler     Distribution.Simple.Configure+    Distribution.Simple.Errors+    Distribution.Simple.FileMonitor.Types     Distribution.Simple.Flag     Distribution.Simple.GHC     Distribution.Simple.GHCJS     Distribution.Simple.Haddock     Distribution.Simple.Glob-    Distribution.Simple.HaskellSuite+    Distribution.Simple.Glob.Internal     Distribution.Simple.Hpc     Distribution.Simple.Install     Distribution.Simple.InstallDirs     Distribution.Simple.InstallDirs.Internal     Distribution.Simple.LocalBuildInfo+    Distribution.Simple.PackageDescription     Distribution.Simple.PackageIndex     Distribution.Simple.PreProcess+    Distribution.Simple.PreProcess.Types     Distribution.Simple.PreProcess.Unlit     Distribution.Simple.Program     Distribution.Simple.Program.Ar@@ -179,140 +161,178 @@     Distribution.Simple.Test.Log     Distribution.Simple.UHC     Distribution.Simple.UserHooks+    Distribution.Simple.SetupHooks.Errors+    Distribution.Simple.SetupHooks.Internal+    Distribution.Simple.SetupHooks.Rule     Distribution.Simple.Utils-    Distribution.SPDX-    Distribution.SPDX.License-    Distribution.SPDX.LicenseId-    Distribution.SPDX.LicenseExceptionId-    Distribution.SPDX.LicenseExpression-    Distribution.SPDX.LicenseListVersion-    Distribution.SPDX.LicenseReference-    Distribution.System     Distribution.TestSuite-    Distribution.Text-    Distribution.Pretty-    Distribution.Types.AbiHash     Distribution.Types.AnnotatedId-    Distribution.Types.Benchmark-    Distribution.Types.BenchmarkInterface-    Distribution.Types.BenchmarkType-    Distribution.Types.BuildInfo-    Distribution.Types.BuildType     Distribution.Types.ComponentInclude-    Distribution.Types.ConfVar-    Distribution.Types.Dependency-    Distribution.Types.ExeDependency-    Distribution.Types.LegacyExeDependency-    Distribution.Types.PkgconfigDependency-    Distribution.Types.DependencyMap-    Distribution.Types.ComponentId-    Distribution.Types.MungedPackageId-    Distribution.Types.PackageId-    Distribution.Types.UnitId-    Distribution.Types.Executable-    Distribution.Types.ExecutableScope-    Distribution.Types.Library-    Distribution.Types.LibraryVisibility-    Distribution.Types.Flag-    Distribution.Types.ForeignLib-    Distribution.Types.ForeignLibType-    Distribution.Types.ForeignLibOption-    Distribution.Types.Module-    Distribution.Types.ModuleReexport-    Distribution.Types.ModuleRenaming-    Distribution.Types.ComponentName-    Distribution.Types.LibraryName-    Distribution.Types.MungedPackageName-    Distribution.Types.PackageName+    Distribution.Types.DumpBuildInfo     Distribution.Types.PackageName.Magic-    Distribution.Types.PkgconfigName-    Distribution.Types.PkgconfigVersion-    Distribution.Types.PkgconfigVersionRange-    Distribution.Types.UnqualComponentName-    Distribution.Types.IncludeRenaming-    Distribution.Types.Mixin-    Distribution.Types.SetupBuildInfo-    Distribution.Types.TestSuite-    Distribution.Types.TestSuiteInterface-    Distribution.Types.TestType-    Distribution.Types.GenericPackageDescription-    Distribution.Types.Condition-    Distribution.Types.CondTree-    Distribution.Types.HookedBuildInfo-    Distribution.Types.PackageDescription-    Distribution.Types.SourceRepo-    Distribution.Types.Component     Distribution.Types.ComponentLocalBuildInfo+    Distribution.Types.LocalBuildConfig     Distribution.Types.LocalBuildInfo-    Distribution.Types.ComponentRequestedSpec     Distribution.Types.TargetInfo-    Distribution.Types.Version-    Distribution.Types.VersionRange-    Distribution.Types.VersionRange.Internal-    Distribution.Types.VersionInterval-    Distribution.Types.VersionInterval.Legacy     Distribution.Types.GivenComponent-    Distribution.Types.PackageVersionConstraint-    Distribution.Utils.Generic+    Distribution.Types.ParStrat+    Distribution.Utils.Json     Distribution.Utils.NubList-    Distribution.Utils.ShortText     Distribution.Utils.Progress     Distribution.Verbosity     Distribution.Verbosity.Internal-    Distribution.Version++  -- We reexport all of Cabal-syntax to aid in compatibility for downstream+  -- users. In the future we may opt to deprecate some or all of these exports.+  -- See haskell/Cabal#7974.+  reexported-modules:+    Distribution.Backpack,+    Distribution.CabalSpecVersion,+    Distribution.Compat.Binary,+    Distribution.Compat.CharParsing,+    Distribution.Compat.DList,+    Distribution.Compat.Exception,+    Distribution.Compat.Graph,+    Distribution.Compat.Lens,+    Distribution.Compat.MonadFail,+    Distribution.Compat.Newtype,+    Distribution.Compat.NonEmptySet,+    Distribution.Compat.Parsing,+    Distribution.Compat.Prelude,+    Distribution.Compat.Semigroup,+    Distribution.Compiler,+    Distribution.FieldGrammar,+    Distribution.FieldGrammar.Class,+    Distribution.FieldGrammar.FieldDescrs,+    Distribution.FieldGrammar.Newtypes,+    Distribution.FieldGrammar.Parsec,+    Distribution.FieldGrammar.Pretty,+    Distribution.Fields,+    Distribution.Fields.ConfVar,+    Distribution.Fields.Field,+    Distribution.Fields.Lexer,+    Distribution.Fields.LexerMonad,+    Distribution.Fields.ParseResult,+    Distribution.Fields.Parser,+    Distribution.Fields.Pretty,+    Distribution.InstalledPackageInfo,+    Distribution.License,+    Distribution.ModuleName,+    Distribution.Package,+    Distribution.PackageDescription,+    Distribution.PackageDescription.Configuration,+    Distribution.PackageDescription.FieldGrammar,+    Distribution.PackageDescription.Parsec,+    Distribution.PackageDescription.PrettyPrint,+    Distribution.PackageDescription.Quirks,+    Distribution.PackageDescription.Utils,+    Distribution.Parsec,+    Distribution.Parsec.Error,+    Distribution.Parsec.FieldLineStream,+    Distribution.Parsec.Position,+    Distribution.Parsec.Warning,+    Distribution.Pretty,+    Distribution.SPDX,+    Distribution.SPDX.License,+    Distribution.SPDX.LicenseExceptionId,+    Distribution.SPDX.LicenseExpression,+    Distribution.SPDX.LicenseId,+    Distribution.SPDX.LicenseListVersion,+    Distribution.SPDX.LicenseReference,+    Distribution.System,+    Distribution.Text,+    Distribution.Types.AbiDependency,+    Distribution.Types.AbiHash,+    Distribution.Types.Benchmark,+    Distribution.Types.Benchmark.Lens,+    Distribution.Types.BenchmarkInterface,+    Distribution.Types.BenchmarkType,+    Distribution.Types.BuildInfo,+    Distribution.Types.BuildInfo.Lens,+    Distribution.Types.BuildType,+    Distribution.Types.Component,+    Distribution.Types.ComponentId,+    Distribution.Types.ComponentName,+    Distribution.Types.ComponentRequestedSpec,+    Distribution.Types.CondTree,+    Distribution.Types.Condition,+    Distribution.Types.ConfVar,+    Distribution.Types.Dependency,+    Distribution.Types.DependencyMap,+    Distribution.Types.DependencySatisfaction,+    Distribution.Types.ExeDependency,+    Distribution.Types.Executable,+    Distribution.Types.Executable.Lens,+    Distribution.Types.ExecutableScope,+    Distribution.Types.ExposedModule,+    Distribution.Types.Flag,+    Distribution.Types.ForeignLib,+    Distribution.Types.ForeignLib.Lens,+    Distribution.Types.ForeignLibOption,+    Distribution.Types.ForeignLibType,+    Distribution.Types.GenericPackageDescription,+    Distribution.Types.GenericPackageDescription.Lens,+    Distribution.Types.HookedBuildInfo,+    Distribution.Types.IncludeRenaming,+    Distribution.Types.InstalledPackageInfo,+    Distribution.Types.InstalledPackageInfo.Lens,+    Distribution.Types.InstalledPackageInfo.FieldGrammar,+    Distribution.Types.LegacyExeDependency,+    Distribution.Types.Lens,+    Distribution.Types.Library,+    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,+    Distribution.Types.ModuleRenaming,+    Distribution.Types.MungedPackageId,+    Distribution.Types.MungedPackageName,+    Distribution.Types.PackageDescription,+    Distribution.Types.PackageDescription.Lens,+    Distribution.Types.PackageId,+    Distribution.Types.PackageId.Lens,+    Distribution.Types.PackageName,+    Distribution.Types.PackageVersionConstraint,+    Distribution.Types.PkgconfigDependency,+    Distribution.Types.PkgconfigName,+    Distribution.Types.PkgconfigVersion,+    Distribution.Types.PkgconfigVersionRange,+    Distribution.Types.SetupBuildInfo,+    Distribution.Types.SetupBuildInfo.Lens,+    Distribution.Types.SourceRepo,+    Distribution.Types.SourceRepo.Lens,+    Distribution.Types.TestSuite,+    Distribution.Types.TestSuite.Lens,+    Distribution.Types.TestSuiteInterface,+    Distribution.Types.TestType,+    Distribution.Types.UnitId,+    Distribution.Types.UnqualComponentName,+    Distribution.Types.Version,+    Distribution.Types.VersionInterval,+    Distribution.Types.VersionInterval.Legacy,+    Distribution.Types.VersionRange,+    Distribution.Types.VersionRange.Internal,+    Distribution.Utils.Base62,+    Distribution.Utils.Generic,+    Distribution.Utils.MD5,+    Distribution.Utils.Path,+    Distribution.Utils.ShortText,+    Distribution.Utils.String,+    Distribution.Utils.Structured,+    Distribution.Version,     Language.Haskell.Extension-    Distribution.Compat.Binary    -- 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.6),-    mtl           >= 2.1      && < 2.3,-    text         (>= 1.2.3.0  && < 1.3) || (>= 2.0 && < 2.1),-    parsec        >= 3.1.13.0 && < 3.2-  exposed-modules:-    Distribution.Compat.Parsing-    Distribution.Compat.CharParsing-    Distribution.FieldGrammar-    Distribution.FieldGrammar.Class-    Distribution.FieldGrammar.FieldDescrs-    Distribution.FieldGrammar.Newtypes-    Distribution.FieldGrammar.Parsec-    Distribution.FieldGrammar.Pretty-    Distribution.PackageDescription.FieldGrammar-    Distribution.PackageDescription.Parsec-    Distribution.PackageDescription.Quirks-    Distribution.Parsec-    Distribution.Parsec.Error-    Distribution.Parsec.Position-    Distribution.Parsec.Warning-    Distribution.Parsec.FieldLineStream-    Distribution.Fields-    Distribution.Fields.ConfVar-    Distribution.Fields.Field-    Distribution.Fields.Lexer-    Distribution.Fields.LexerMonad-    Distribution.Fields.ParseResult-    Distribution.Fields.Parser-    Distribution.Fields.Pretty--  -- Lens functionality-  exposed-modules:-    Distribution.Compat.Lens-    Distribution.Types.Lens-    Distribution.Types.Benchmark.Lens-    Distribution.Types.BuildInfo.Lens-    Distribution.Types.Executable.Lens-    Distribution.Types.ForeignLib.Lens-    Distribution.Types.GenericPackageDescription.Lens-    Distribution.Types.InstalledPackageInfo.Lens-    Distribution.Types.Library.Lens-    Distribution.Types.PackageDescription.Lens-    Distribution.Types.PackageId.Lens-    Distribution.Types.SetupBuildInfo.Lens-    Distribution.Types.SourceRepo.Lens-    Distribution.Types.TestSuite.Lens+    , transformers (>= 0.3      && < 0.4) || (>=0.4.1.0 && <0.7)+    , mtl           >= 2.1      && < 2.4+    , parsec        >= 3.1.13.0 && < 3.2    other-modules:     Distribution.Backpack.PreExistingComponent@@ -322,29 +342,49 @@     Distribution.Backpack.UnifyM     Distribution.Backpack.Id     Distribution.Utils.UnionFind-    Distribution.Utils.Base62     Distribution.Compat.Async     Distribution.Compat.CopyFile     Distribution.Compat.GetShortPathName-    Distribution.Compat.MonadFail-    Distribution.Compat.Prelude     Distribution.Compat.SnocList     Distribution.GetOpt     Distribution.Lex-    Distribution.Utils.String+    Distribution.PackageDescription.Check.Common+    Distribution.PackageDescription.Check.Conditional+    Distribution.PackageDescription.Check.Monad+    Distribution.PackageDescription.Check.Paths+    Distribution.PackageDescription.Check.Target+    Distribution.PackageDescription.Check.Warning     Distribution.Simple.Build.Macros.Z+    Distribution.Simple.Build.PackageInfoModule.Z     Distribution.Simple.Build.PathsModule.Z+    Distribution.Simple.GHC.Build+    Distribution.Simple.GHC.Build.ExtraSources+    Distribution.Simple.GHC.Build.Link+    Distribution.Simple.GHC.Build.Modules+    Distribution.Simple.GHC.Build.Utils     Distribution.Simple.GHC.EnvironmentParser     Distribution.Simple.GHC.Internal     Distribution.Simple.GHC.ImplInfo-    Distribution.Simple.Utils.Json+    Distribution.Simple.ConfigureScript+    Distribution.Simple.Setup.Benchmark+    Distribution.Simple.Setup.Build+    Distribution.Simple.Setup.Clean+    Distribution.Simple.Setup.Common+    Distribution.Simple.Setup.Config+    Distribution.Simple.Setup.Copy+    Distribution.Simple.Setup.Global+    Distribution.Simple.Setup.Haddock+    Distribution.Simple.Setup.Hscolour+    Distribution.Simple.Setup.Install+    Distribution.Simple.Setup.Register+    Distribution.Simple.Setup.Repl+    Distribution.Simple.Setup.SDist+    Distribution.Simple.Setup.Test     Distribution.ZinzaPrelude     Paths_Cabal -  if flag(bundled-binary-generic)-    other-modules:-      Distribution.Compat.Binary.Class-      Distribution.Compat.Binary.Generic+  autogen-modules:+    Paths_Cabal    other-extensions:     BangPatterns@@ -361,8 +401,10 @@     GeneralizedNewtypeDeriving     ImplicitParams     KindSignatures+    LambdaCase     NondecreasingIndentation     OverloadedStrings+    PatternSynonyms     RankNTypes     RecordWildCards     ScopedTypeVariables@@ -372,6 +414,3 @@     TypeOperators     TypeSynonymInstances     UndecidableInstances--  if impl(ghc >= 7.11)-    other-extensions: PatternSynonyms
ChangeLog.md view
@@ -1,16 +1,55 @@+# 3.16.1.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) December 2025+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.16.1.0.md++# 3.16.0.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) July 2025+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.16.0.0.md++# 3.14.2.0 [Mikolaj Konarski](mailto:mikolaj@well-typed.com) April 2025+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.14.2.0.md++# 3.14.1.0 [Hécate](mailto:hecate+github@glitchbra.in) November 2024+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.14.1.0.md++# 3.14.0.0 [Hécate](mailto:hecate+github@glitchbra.in) September 2024+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.14.0.0.md++# 3.12.1.0 [Artem Pelenitsyn](mailto:a.pelenitsyn@gmail.com) June 2024+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.12.1.0.md++# 3.12.0.0 [Francesco Ariis](mailto:fa-ml@ariis.it) May 2024+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.12.0.0.md++# 3.10.3.0 [Hécate](mailto:hecate+github@glitchbra.in) January 2024+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.3.0.md++# 3.10.2.1 [Hécate](mailto:hecate+github@glitchbra.in) October 2023+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.2.1.md++# 3.10.2.0 [Hécate](mailto:hecate+github@glitchbra.in) August 2023+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.2.0.md++# 3.10.1.0 [Mikolaj Konarski](mailto:mikolaj@well-typed.com) March 2023+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.1.0.md++# 3.8.1.0 [Mikolaj Konarski](mailto:mikolaj@well-typed.com) August 2022+  * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.8.1.0.md+ # 3.6.3.0 March 2022   * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.3.0.md -# 3.6.2.0 [Emily Pillmore](mailgo:emilypi@cohomolo.gy) October 2021+# 3.6.2.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) October 2021   * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.2.0.md -# 3.6.1.0 [Emily Pillmore](mailgo:emilypi@cohomolo.gy) August 2021+# 3.6.1.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) August 2021   * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.1.0.md -# 3.6.0.0 [Emily Pillmore](mailgo:emilypi@cohomolo.gy) August 2021+# 3.6.0.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) August 2021   * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.0.0.md -# 3.4.0.0 [Oleg Grenrus](mailgo:oleg.grnerus@iki.fi) February 2021+# 3.4.1.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) October 2021+  * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.4.1.0.md++# 3.4.0.0 [Oleg Grenrus](mailto:oleg.grnerus@iki.fi) February 2021   * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.4.0.0.md  # 3.2.1.0 [Oleg Grenrus](mailto:oleg.grenris@iki.fi) October 2020@@ -743,7 +782,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-2020, Cabal Development Team.+Copyright (c) 2003-2025, Cabal Development Team. See the AUTHORS file for the full list of copyright holders.  See */LICENSE for the copyright holders of the subcomponents.
README.md view
@@ -6,17 +6,17 @@ If you also want the `cabal` command-line program, you need the [cabal-install] package in addition to this library. -[cabal-install]: ../cabal-install/README.md+[cabal-install]: ../cabal-install  More information ================ -Please see the [Cabal web site] for the [user guide] and [API+Please see the [Cabal web site], the [user guide] and the [API documentation]. There is additional information available on the [development wiki].  [user guide]:        http://www.haskell.org/cabal/users-guide-[API documentation]: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html+[API documentation]: https://hackage.haskell.org/package/Cabal/docs/Distribution-Simple.html [development wiki]:  https://github.com/haskell/cabal/wiki  @@ -34,8 +34,8 @@ [Hackage]. You may have a favourite Cabal bug or limitation. Look at Cabal's [bug tracker]. Ensure that the problem is reported there and adequately described. Comment on the issue to report how much of a-problem the bug is for you. Subscribe to the issues's notifications to-discussed requirements and keep informed on progress. For feature+problem the bug is for you. Subscribe to the issue's notifications to+discuss requirements and keep informed on progress. For feature requests, it is helpful if there is a description of how you would expect to interact with the new feature.
Setup.hs view
@@ -1,4 +1,5 @@ import Distribution.Simple+ main :: IO () main = defaultMain
− src/Distribution/Backpack.hs 
@@ -1,269 +0,0 @@-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PatternGuards              #-}-{-# LANGUAGE RankNTypes                 #-}---- | This module defines the core data types for Backpack.  For more--- details, see:------  <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>--module Distribution.Backpack (-    -- * OpenUnitId-    OpenUnitId(..),-    openUnitIdFreeHoles,-    mkOpenUnitId,--    -- * DefUnitId-    DefUnitId,-    unDefUnitId,-    mkDefUnitId,--    -- * OpenModule-    OpenModule(..),-    openModuleFreeHoles,--    -- * OpenModuleSubst-    OpenModuleSubst,-    dispOpenModuleSubst,-    dispOpenModuleSubstEntry,-    parsecOpenModuleSubst,-    parsecOpenModuleSubstEntry,-    openModuleSubstFreeHoles,--    -- * Conversions to 'UnitId'-    abstractUnitId,-    hashModuleSubst,-) where--import Distribution.Compat.Prelude hiding (mod)-import Distribution.Parsec-import Distribution.Pretty-import Prelude ()-import Text.PrettyPrint            (hcat)--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp--import Distribution.ModuleName-import Distribution.Types.ComponentId-import Distribution.Types.Module-import Distribution.Types.UnitId-import Distribution.Utils.Base62--import qualified Data.Map as Map-import qualified Data.Set as Set---------------------------------------------------------------------------- OpenUnitId---- | An 'OpenUnitId' describes a (possibly partially) instantiated--- Backpack component, with a description of how the holes are filled--- in.  Unlike 'OpenUnitId', the 'ModuleSubst' is kept in a structured--- form that allows for substitution (which fills in holes.) This form--- of unit cannot be installed. It must first be converted to a--- 'UnitId'.------ In the absence of Backpack, there are no holes to fill, so any such--- component always has an empty module substitution; thus we can lossly--- represent it as an 'OpenUnitId uid'.------ For a source component using Backpack, however, there is more--- structure as components may be parametrized over some signatures, and--- these \"holes\" may be partially or wholly filled.------ OpenUnitId plays an important role when we are mix-in linking,--- and is recorded to the installed packaged database for indefinite--- packages; however, for compiled packages that are fully instantiated,--- we instantiate 'OpenUnitId' into 'UnitId'.------ For more details see the Backpack spec--- <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-----data OpenUnitId-    -- | Identifies a component which may have some unfilled holes;-    -- specifying its 'ComponentId' and its 'OpenModuleSubst'.-    -- TODO: Invariant that 'OpenModuleSubst' is non-empty?-    -- See also the Text instance.-    = IndefFullUnitId ComponentId OpenModuleSubst-    -- | Identifies a fully instantiated component, which has-    -- been compiled and abbreviated as a hash.  The embedded 'UnitId'-    -- MUST NOT be for an indefinite component; an 'OpenUnitId'-    -- is guaranteed not to have any holes.-    | DefiniteUnitId DefUnitId-  deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)--- TODO: cache holes?--instance Binary OpenUnitId-instance Structured OpenUnitId -instance NFData OpenUnitId where-    rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst-    rnf (DefiniteUnitId uid) = rnf uid--instance Pretty OpenUnitId where-    pretty (IndefFullUnitId cid insts)-        -- TODO: arguably a smart constructor to enforce invariant would be-        -- better-        | Map.null insts = pretty cid-        | otherwise      = pretty cid <<>> Disp.brackets (dispOpenModuleSubst insts)-    pretty (DefiniteUnitId uid) = pretty uid---- |------ >>> eitherParsec "foobar" :: Either String OpenUnitId---Right (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "foobar"}))------ >>> eitherParsec "foo[Str=text-1.2.3:Data.Text.Text]" :: Either String OpenUnitId--- Right (IndefFullUnitId (ComponentId "foo") (fromList [(ModuleName "Str",OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "text-1.2.3"})) (ModuleName "Data.Text.Text"))]))----instance Parsec OpenUnitId where-    parsec = P.try parseOpenUnitId <|> fmap DefiniteUnitId parsec-      where-        parseOpenUnitId = do-            cid <- parsec-            insts <- P.between (P.char '[') (P.char ']')-                       parsecOpenModuleSubst-            return (IndefFullUnitId cid insts)---- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'.-openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName-openUnitIdFreeHoles (IndefFullUnitId _ insts) = openModuleSubstFreeHoles insts-openUnitIdFreeHoles _ = Set.empty---- | Safe constructor from a UnitId.  The only way to do this safely--- is if the instantiation is provided.-mkOpenUnitId :: UnitId -> ComponentId -> OpenModuleSubst -> OpenUnitId-mkOpenUnitId uid cid insts =-    if Set.null (openModuleSubstFreeHoles insts)-        then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds!-        else IndefFullUnitId cid insts---------------------------------------------------------------------------- DefUnitId---- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation--- with no holes.-mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId-mkDefUnitId cid insts =-    unsafeMkDefUnitId (mkUnitId-        (unComponentId cid ++ maybe "" ("+"++) (hashModuleSubst insts)))-        -- impose invariant!---------------------------------------------------------------------------- OpenModule---- | Unlike a 'Module', an 'OpenModule' is either an ordinary--- module from some unit, OR an 'OpenModuleVar', representing a--- hole that needs to be filled in.  Substitutions are over--- module variables.-data OpenModule-    = OpenModule OpenUnitId ModuleName-    | OpenModuleVar ModuleName-  deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)--instance Binary OpenModule-instance Structured OpenModule--instance NFData OpenModule where-    rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name-    rnf (OpenModuleVar mod_name) = rnf mod_name--instance Pretty OpenModule where-    pretty (OpenModule uid mod_name) =-        hcat [pretty uid, Disp.text ":", pretty mod_name]-    pretty (OpenModuleVar mod_name) =-        hcat [Disp.char '<', pretty mod_name, Disp.char '>']---- |------ >>> eitherParsec "Includes2-0.1.0.0-inplace-mysql:Database.MySQL" :: Either String OpenModule--- Right (OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "Includes2-0.1.0.0-inplace-mysql"})) (ModuleName "Database.MySQL"))----instance Parsec OpenModule where-    parsec = parsecModuleVar <|> parsecOpenModule-      where-        parsecOpenModule = do-            uid <- parsec-            _ <- P.char ':'-            mod_name <- parsec-            return (OpenModule uid mod_name)--        parsecModuleVar = do-            _ <- P.char '<'-            mod_name <- parsec-            _ <- P.char '>'-            return (OpenModuleVar mod_name)---- | Get the set of holes ('ModuleVar') embedded in a 'Module'.-openModuleFreeHoles :: OpenModule -> Set ModuleName-openModuleFreeHoles (OpenModuleVar mod_name) = Set.singleton mod_name-openModuleFreeHoles (OpenModule uid _n) = openUnitIdFreeHoles uid---------------------------------------------------------------------------- OpenModuleSubst---- | An explicit substitution on modules.------ NB: These substitutions are NOT idempotent, for example, a--- valid substitution is (A -> B, B -> A).-type OpenModuleSubst = Map ModuleName OpenModule---- | Pretty-print the entries of a module substitution, suitable--- for embedding into a 'OpenUnitId' or passing to GHC via @--instantiate-with@.-dispOpenModuleSubst :: OpenModuleSubst -> Disp.Doc-dispOpenModuleSubst subst-    = Disp.hcat-    . Disp.punctuate Disp.comma-    $ map dispOpenModuleSubstEntry (Map.toAscList subst)---- | Pretty-print a single entry of a module substitution.-dispOpenModuleSubstEntry :: (ModuleName, OpenModule) -> Disp.Doc-dispOpenModuleSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v---- | Inverse to 'dispModSubst'.------ @since 2.2-parsecOpenModuleSubst :: CabalParsing m => m OpenModuleSubst-parsecOpenModuleSubst = fmap Map.fromList-      . flip P.sepBy (P.char ',')-      $ parsecOpenModuleSubstEntry---- | Inverse to 'dispModSubstEntry'.------ @since 2.2-parsecOpenModuleSubstEntry :: CabalParsing m => m (ModuleName, OpenModule)-parsecOpenModuleSubstEntry =-    do k <- parsec-       _ <- P.char '='-       v <- parsec-       return (k, v)---- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'.--- This is NOT the domain of the substitution.-openModuleSubstFreeHoles :: OpenModuleSubst -> Set ModuleName-openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems insts))---------------------------------------------------------------------------- Conversions to UnitId---- | When typechecking, we don't demand that a freshly instantiated--- 'IndefFullUnitId' be compiled; instead, we just depend on the--- installed indefinite unit installed at the 'ComponentId'.-abstractUnitId :: OpenUnitId -> UnitId-abstractUnitId (DefiniteUnitId def_uid) = unDefUnitId def_uid-abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid---- | Take a module substitution and hash it into a string suitable for--- 'UnitId'.  Note that since this takes 'Module', not 'OpenModule',--- you are responsible for recursively converting 'OpenModule'--- into 'Module'.  See also "Distribution.Backpack.ReadyComponent".-hashModuleSubst :: Map ModuleName Module -> Maybe String-hashModuleSubst subst-  | Map.null subst = Nothing-  | otherwise =-      Just . hashToBase62 $-        concat [ prettyShow mod_name ++ "=" ++ prettyShow m ++ "\n"-               | (mod_name, m) <- Map.toList subst]
src/Distribution/Backpack/ComponentsGraph.hs view
@@ -1,24 +1,24 @@ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.ComponentsGraph (-    ComponentsGraph,-    ComponentsWithDeps,-    mkComponentsGraph,-    componentsGraphToList,-    dispComponentsWithDeps,-    componentCycleMsg-) where+module Distribution.Backpack.ComponentsGraph+  ( ComponentsGraph+  , ComponentsWithDeps+  , mkComponentsGraph+  , componentsGraphToList+  , dispComponentsWithDeps+  , componentCycleMsg+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () +import Distribution.Compat.Graph (Graph, Node (..))+import qualified Distribution.Compat.Graph as Graph+import qualified Distribution.Compat.NonEmptySet as NES import Distribution.Package import Distribution.PackageDescription import Distribution.Simple.BuildToolDepends import Distribution.Simple.LocalBuildInfo import Distribution.Types.ComponentRequestedSpec-import Distribution.Compat.Graph (Graph, Node(..))-import qualified Distribution.Compat.Graph as Graph-import qualified Distribution.Compat.NonEmptySet as NES import Distribution.Utils.Generic  import Distribution.Pretty (pretty)@@ -30,68 +30,76 @@  -- | A graph of source-level components by their source-level -- dependencies--- type ComponentsGraph = Graph (Node ComponentName Component)  -- | A list of components associated with the source level -- dependencies between them.--- type ComponentsWithDeps = [(Component, [ComponentName])]  -- | Pretty-print 'ComponentsWithDeps'.--- dispComponentsWithDeps :: ComponentsWithDeps -> Doc dispComponentsWithDeps graph =-    vcat [ hang (text "component" <+> pretty (componentName c)) 4-                (vcat [ text "dependency" <+> pretty cdep | cdep <- cdeps ])-         | (c, cdeps) <- graph ]+  vcat+    [ hang+      (text "component" <+> pretty (componentName c))+      4+      (vcat [text "dependency" <+> pretty cdep | cdep <- cdeps])+    | (c, cdeps) <- graph+    ]  -- | Create a 'Graph' of 'Component', or report a cycle if there is a -- problem.----mkComponentsGraph :: ComponentRequestedSpec-                  -> PackageDescription-                  -> Either [ComponentName] ComponentsGraph+mkComponentsGraph+  :: ComponentRequestedSpec+  -> PackageDescription+  -> Either [ComponentName] ComponentsGraph mkComponentsGraph enabled pkg_descr =-    let g = Graph.fromDistinctList-                           [ N c (componentName c) (componentDeps c)-                           | c <- pkgBuildableComponents pkg_descr-                           , componentEnabled enabled c ]-    in case Graph.cycles g of-          []     -> Right g-          ccycles -> Left  [ componentName c | N c _ _ <- concat ccycles ]+  let g =+        Graph.fromDistinctList+          [ N c (componentName c) (componentDeps c)+          | c <- pkgBuildableComponents pkg_descr+          , componentEnabled enabled c+          ]+   in case Graph.cycles g of+        [] -> Right g+        ccycles -> Left [componentName c | N c _ _ <- concat ccycles]   where     -- The dependencies for the given component     componentDeps component =-        toolDependencies ++ libDependencies+      toolDependencies ++ libDependencies       where         bi = componentBuildInfo component          toolDependencies = CExeName <$> getAllInternalToolDependencies pkg_descr bi          libDependencies = do-            Dependency pkgname _ lns <- targetBuildDepends bi-            guard (pkgname == packageName pkg_descr)+          Dependency pkgname _ lns <- targetBuildDepends bi+          guard (pkgname == packageName pkg_descr) -            ln <- NES.toList lns-            return (CLibName ln)+          ln <- NES.toList lns+          return (CLibName ln)  -- | Given the package description and a 'PackageDescription' (used -- to determine if a package name is internal or not), sort the -- components in dependency order (fewest dependencies first).  This is -- NOT necessarily the build order (although it is in the absence of -- Backpack.)----componentsGraphToList :: ComponentsGraph-                      -> ComponentsWithDeps+componentsGraphToList+  :: ComponentsGraph+  -> ComponentsWithDeps componentsGraphToList =-    map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort+  map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort  -- | Error message when there is a cycle; takes the SCC of components. componentCycleMsg :: PackageIdentifier -> [ComponentName] -> Doc componentCycleMsg pn cnames =-    text "Components in the package" <+> pretty pn <+> text "depend on each other in a cyclic way:"-    $$-    text (intercalate " depends on "-            [ "'" ++ showComponentName cname ++ "'"-            | cname <- cnames ++ maybeToList (safeHead cnames) ])+  text "Components in the package"+    <+> pretty pn+    <+> text "depend on each other in a cyclic way:"+    $$ text+      ( intercalate+          " depends on "+          [ "'" ++ showComponentName cname ++ "'"+          | cname <- cnames ++ maybeToList (safeHead cnames)+          ]+      )
src/Distribution/Backpack/Configure.hs view
@@ -1,56 +1,58 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-}-{-# LANGUAGE NondecreasingIndentation #-}  -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst> -- -- WARNING: The contents of this module are HIGHLY experimental. -- We may refactor it under you.-module Distribution.Backpack.Configure (-    configureComponentLocalBuildInfos,-) where+module Distribution.Backpack.Configure+  ( configureComponentLocalBuildInfos+  ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>))+import Prelude ()  import Distribution.Backpack-import Distribution.Backpack.FullUnitId-import Distribution.Backpack.PreExistingComponent+import Distribution.Backpack.ComponentsGraph import Distribution.Backpack.ConfiguredComponent+import Distribution.Backpack.FullUnitId+import Distribution.Backpack.Id import Distribution.Backpack.LinkedComponent+import Distribution.Backpack.PreExistingComponent import Distribution.Backpack.ReadyComponent-import Distribution.Backpack.ComponentsGraph-import Distribution.Backpack.Id -import Distribution.Simple.Compiler-import Distribution.Package+import Distribution.Backpack.ModuleShape+import Distribution.Compat.Graph (Graph, IsNode (..))+import qualified Distribution.Compat.Graph as Graph+import Distribution.InstalledPackageInfo+  ( InstalledPackageInfo+  , emptyInstalledPackageInfo+  ) import qualified Distribution.InstalledPackageInfo as Installed-import Distribution.InstalledPackageInfo (InstalledPackageInfo-                                         ,emptyInstalledPackageInfo)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import Distribution.PackageDescription import Distribution.ModuleName-import Distribution.Simple.Setup as Setup+import Distribution.Package+import Distribution.PackageDescription (FlagAssignment, PackageDescription (..), libName)+import Distribution.Simple.Compiler+import Distribution.Simple.Flag import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Types.AnnotatedId-import Distribution.Types.ComponentRequestedSpec import Distribution.Types.ComponentInclude+import Distribution.Types.ComponentRequestedSpec import Distribution.Types.MungedPackageName-import Distribution.Verbosity-import qualified Distribution.Compat.Graph as Graph-import Distribution.Compat.Graph (Graph, IsNode(..)) import Distribution.Utils.LogProgress+import Distribution.Verbosity  import Data.Either-    ( lefts )-import qualified Data.Set as Set+  ( lefts+  ) import qualified Data.Map as Map+import qualified Data.Set as Set import Distribution.Pretty import Text.PrettyPrint @@ -59,144 +61,235 @@ ------------------------------------------------------------------------------  configureComponentLocalBuildInfos-    :: Verbosity-    -> Bool                   -- use_external_internal_deps-    -> ComponentRequestedSpec-    -> Bool                   -- deterministic-    -> Flag String            -- configIPID-    -> Flag ComponentId       -- configCID-    -> PackageDescription-    -> [PreExistingComponent]-    -> FlagAssignment         -- configConfigurationsFlags-    -> [(ModuleName, Module)] -- configInstantiateWith-    -> InstalledPackageIndex-    -> Compiler-    -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)+  :: Verbosity+  -> Bool -- use_external_internal_deps+  -> ComponentRequestedSpec+  -> Bool -- deterministic+  -> Flag String -- configIPID+  -> Flag ComponentId -- configCID+  -> PackageDescription+  -> ([PreExistingComponent], [ConfiguredPromisedComponent])+  -> FlagAssignment -- configConfigurationsFlags+  -> [(ModuleName, Module)] -- configInstantiateWith+  -> InstalledPackageIndex+  -> Compiler+  -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) configureComponentLocalBuildInfos-    verbosity use_external_internal_deps enabled deterministic ipid_flag cid_flag pkg_descr-    prePkgDeps flagAssignment instantiate_with installedPackageSet comp = do+  verbosity+  use_external_internal_deps+  enabled+  deterministic+  ipid_flag+  cid_flag+  pkg_descr+  (prePkgDeps, promisedPkgDeps)+  flags+  instantiate_with+  installedPackageSet+  comp = do     -- NB: In single component mode, this returns a *single* component.     -- In this graph, the graph is NOT closed.     graph0 <- case mkComponentsGraph enabled pkg_descr of-                Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle)-                Right g -> return (componentsGraphToList g)-    infoProgress $ hang (text "Source component graph:") 4-                        (dispComponentsWithDeps graph0)+      Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle)+      Right g -> return (componentsGraphToList g)+    infoProgress $+      hang+        (text "Source component graph:")+        4+        (dispComponentsWithDeps graph0) -    let conf_pkg_map = Map.fromListWith Map.union-            [(pc_pkgname pkg,-                Map.singleton (pc_compname pkg)-                              (AnnotatedId {-                                ann_id = pc_cid pkg,-                                ann_pid = packageId pkg,-                                ann_cname = pc_compname pkg-                              }))-            | pkg <- prePkgDeps]-    graph1 <- toConfiguredComponents use_external_internal_deps-                    flagAssignment-                    deterministic ipid_flag cid_flag pkg_descr-                    conf_pkg_map (map fst graph0)-    infoProgress $ hang (text "Configured component graph:") 4-                        (vcat (map dispConfiguredComponent graph1))+    let conf_pkg_map =+          Map.fromListWith+            Map.union+            $+            -- Normal dependencies+            [ ( pc_pkgname pkg+              , Map.singleton+                  (pc_compname pkg)+                  ( AnnotatedId+                      { ann_id = pc_cid pkg+                      , ann_pid = packageId pkg+                      , ann_cname = pc_compname pkg+                      }+                  )+              )+            | pkg <- prePkgDeps+            ]+              +++              -- Promised dependencies+              [ (pkg, Map.singleton (ann_cname aid) aid)+              | ConfiguredPromisedComponent pkg aid <- promisedPkgDeps+              ]+    graph1 <-+      toConfiguredComponents+        use_external_internal_deps+        flags+        deterministic+        ipid_flag+        cid_flag+        pkg_descr+        conf_pkg_map+        (map fst graph0)+    infoProgress $+      hang+        (text "Configured component graph:")+        4+        (vcat (map dispConfiguredComponent graph1)) -    let shape_pkg_map = Map.fromList+    let shape_pkg_map =+          Map.fromList             [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg))-            | pkg <- prePkgDeps]+            | pkg <- prePkgDeps+            ]+            `Map.union` Map.fromList+              [ ( ann_id aid+                ,+                  ( DefiniteUnitId+                      ( unsafeMkDefUnitId+                          (mkUnitId (unComponentId (ann_id aid)))+                      )+                  , emptyModuleShape+                  )+                )+              | ConfiguredPromisedComponent _ aid <- promisedPkgDeps+              ]         uid_lookup def_uid-            | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid-            = FullUnitId (Installed.installedComponentId pkg)-                 (Map.fromList (Installed.instantiatedWith pkg))-            | otherwise = error ("uid_lookup: " ++ prettyShow uid)-          where uid = unDefUnitId def_uid-    graph2 <- toLinkedComponents verbosity uid_lookup-                    (package pkg_descr) shape_pkg_map graph1+          | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid =+              FullUnitId+                (Installed.installedComponentId pkg)+                (Map.fromList (Installed.instantiatedWith pkg))+          | otherwise = error ("uid_lookup: " ++ prettyShow uid)+          where+            uid = unDefUnitId def_uid+    graph2 <-+      toLinkedComponents+        verbosity+        (not (null promisedPkgDeps))+        uid_lookup+        (package pkg_descr)+        shape_pkg_map+        graph1      infoProgress $-        hang (text "Linked component graph:") 4-             (vcat (map dispLinkedComponent graph2))+      hang+        (text "Linked component graph:")+        4+        (vcat (map dispLinkedComponent graph2)) -    let pid_map = Map.fromList $+    let pid_map =+          Map.fromList $             [ (pc_uid pkg, pc_munged_id pkg)-            | pkg <- prePkgDeps] ++-            [ (Installed.installedUnitId pkg, mungedId pkg)-            | (_, Module uid _) <- instantiate_with-            , Just pkg <- [PackageIndex.lookupUnitId-                                installedPackageSet (unDefUnitId uid)] ]+            | pkg <- prePkgDeps+            ]+              ++ [ (Installed.installedUnitId pkg, mungedId pkg)+                 | (_, Module uid _) <- instantiate_with+                 , Just pkg <-+                    [ PackageIndex.lookupUnitId+                        installedPackageSet+                        (unDefUnitId uid)+                    ]+                 ]         subst = Map.fromList instantiate_with         graph3 = toReadyComponents pid_map subst graph2         graph4 = Graph.revTopSort (Graph.fromDistinctList graph3) -    infoProgress $ hang (text "Ready component graph:") 4-                        (vcat (map dispReadyComponent graph4))+    infoProgress $+      hang+        (text "Ready component graph:")+        4+        (vcat (map dispReadyComponent graph4)) -    toComponentLocalBuildInfos comp installedPackageSet pkg_descr prePkgDeps graph4+    toComponentLocalBuildInfos comp installedPackageSet promisedPkgDeps pkg_descr prePkgDeps graph4  ------------------------------------------------------------------------------ -- ComponentLocalBuildInfo ------------------------------------------------------------------------------  toComponentLocalBuildInfos-    :: Compiler-    -> InstalledPackageIndex -- FULL set-    -> PackageDescription-    -> [PreExistingComponent] -- external package deps-    -> [ReadyComponent]-    -> LogProgress ([ComponentLocalBuildInfo],-                    InstalledPackageIndex) -- only relevant packages+  :: Compiler+  -> InstalledPackageIndex -- FULL set+  -> [ConfiguredPromisedComponent]+  -> PackageDescription+  -> [PreExistingComponent] -- external package deps+  -> [ReadyComponent]+  -> LogProgress+      ( [ComponentLocalBuildInfo]+      , InstalledPackageIndex -- only relevant packages+      ) toComponentLocalBuildInfos-    comp installedPackageSet pkg_descr externalPkgDeps graph = do+  comp+  installedPackageSet+  promisedPkgDeps+  pkg_descr+  externalPkgDeps+  graph = do     -- Check and make sure that every instantiated component exists.     -- We have to do this now, because prior to linking/instantiating     -- we don't actually know what the full set of 'UnitId's we need     -- are.-    let -- TODO: This is actually a bit questionable performance-wise,-        -- since we will pay for the ALL installed packages even if-        -- they are not related to what we are building.  This was true-        -- in the old configure code.-        external_graph :: Graph (Either InstalledPackageInfo ReadyComponent)-        external_graph = Graph.fromDistinctList-                       . map Left-                       $ PackageIndex.allPackages installedPackageSet-        internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent)-        internal_graph = Graph.fromDistinctList-                       . map Right-                       $ graph-        combined_graph = Graph.unionRight external_graph internal_graph-        local_graph = fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing")-                    $ Graph.closure combined_graph (map nodeKey graph)-        -- The database of transitively reachable installed packages that the-        -- external components the package (as a whole) depends on.  This will be-        -- used in several ways:-        ---        --      * We'll use it to do a consistency check so we're not depending-        --        on multiple versions of the same package (TODO: someday relax-        --        this for private dependencies.)  See right below.-        ---        --      * We'll pass it on in the LocalBuildInfo, where preprocessors-        --        and other things will incorrectly use it to determine what-        --        the include paths and everything should be.-        ---        packageDependsIndex = PackageIndex.fromList (lefts local_graph)-        fullIndex = Graph.fromDistinctList local_graph+    let+      -- TODO: This is actually a bit questionable performance-wise,+      -- since we will pay for the ALL installed packages even if+      -- they are not related to what we are building.  This was true+      -- in the old configure code.+      external_graph :: Graph (Either InstalledPackageInfo ReadyComponent)+      external_graph =+        Graph.fromDistinctList+          . map Left+          $ PackageIndex.allPackages installedPackageSet+      internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent)+      internal_graph =+        Graph.fromDistinctList+          . map Right+          $ graph+      combined_graph = Graph.unionRight external_graph internal_graph+      local_graph =+        fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") $+          Graph.closure combined_graph (map nodeKey graph)+      -- The database of transitively reachable installed packages that the+      -- external components the package (as a whole) depends on.  This will be+      -- used in several ways:+      --+      --      * We'll use it to do a consistency check so we're not depending+      --        on multiple versions of the same package (TODO: someday relax+      --        this for private dependencies.)  See right below.+      --+      --      * We'll pass it on in the LocalBuildInfo, where preprocessors+      --        and other things will incorrectly use it to determine what+      --        the include paths and everything should be.+      --+      packageDependsIndex = PackageIndex.fromList (lefts local_graph)+      fullIndex = Graph.fromDistinctList local_graph+     case Graph.broken fullIndex of-        [] -> return ()-        broken ->-          -- TODO: ppr this-          dieProgress . text $-                "The following packages are broken because other"-             ++ " packages they depend on are missing. These broken "-             ++ "packages must be rebuilt before they can be used.\n"-             -- TODO: Undupe.-             ++ unlines [ "installed package "-                       ++ prettyShow (packageId pkg)-                       ++ " is broken due to missing package "-                       ++ intercalate ", " (map prettyShow deps)-                        | (Left pkg, deps) <- broken ]-             ++ unlines [ "planned package "-                       ++ prettyShow (packageId pkg)-                       ++ " is broken due to missing package "-                       ++ intercalate ", " (map prettyShow deps)-                        | (Right pkg, deps) <- broken ]+      [] -> return ()+      -- If there are promised dependencies, we don't know what the dependencies+      -- of these are and that can easily lead to a broken graph. So assume that+      -- any promised package is not broken (ie all its dependencies, transitively,+      -- will be there). That's a promise.+      broken+        | not (null promisedPkgDeps) -> return ()+        | otherwise ->+            -- TODO: ppr this+            dieProgress . text $+              "The following packages are broken because other"+                ++ " packages they depend on are missing. These broken "+                ++ "packages must be rebuilt before they can be used.\n"+                -- TODO: Undupe.+                ++ unlines+                  [ "installed package "+                    ++ prettyShow (packageId pkg)+                    ++ " is broken due to missing package "+                    ++ intercalate ", " (map prettyShow deps)+                  | (Left pkg, deps) <- broken+                  ]+                ++ unlines+                  [ "planned package "+                    ++ prettyShow (packageId pkg)+                    ++ " is broken due to missing package "+                    ++ intercalate ", " (map prettyShow deps)+                  | (Right pkg, deps) <- broken+                  ]      -- In this section, we'd like to look at the 'packageDependsIndex'     -- and see if we've picked multiple versions of the same@@ -213,25 +306,34 @@     --     -- TODO: This is probably wrong for Backpack     let pseudoTopPkg :: InstalledPackageInfo-        pseudoTopPkg = emptyInstalledPackageInfo {-            Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr),-            Installed.sourcePackageId = packageId pkg_descr,-            Installed.depends = map pc_uid externalPkgDeps-          }+        pseudoTopPkg =+          emptyInstalledPackageInfo+            { Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr)+            , Installed.sourcePackageId = packageId pkg_descr+            , Installed.depends = map pc_uid externalPkgDeps+            }     case PackageIndex.dependencyInconsistencies-       . PackageIndex.insert pseudoTopPkg-       $ packageDependsIndex of+      . PackageIndex.insert pseudoTopPkg+      $ packageDependsIndex of       [] -> return ()       inconsistencies ->         warnProgress $-          hang (text "This package indirectly depends on multiple versions of the same" <+>-                text "package. This is very likely to cause a compile failure.") 2-               (vcat [ text "package" <+> pretty (packageName user) <+>-                       parens (pretty (installedUnitId user)) <+> text "requires" <+>-                       pretty inst-                     | (_dep_key, insts) <- inconsistencies-                     , (inst, users) <- insts-                     , user <- users ])+          hang+            ( text "This package indirectly depends on multiple versions of the same"+                <+> text "package. This is very likely to cause a compile failure."+            )+            2+            ( vcat+                [ text "package"+                  <+> pretty (packageName user)+                  <+> parens (pretty (installedUnitId user))+                  <+> text "requires"+                  <+> pretty inst+                | (_dep_key, insts) <- inconsistencies+                , (inst, users) <- insts+                , user <- users+                ]+            )     let clbis = mkLinkedComponentsLocalBuildInfo comp graph     -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps)     return (clbis, packageDependsIndex)@@ -241,119 +343,124 @@ -- -- This conversion is lossy; we lose some invariants from ReadyComponent mkLinkedComponentsLocalBuildInfo-    :: Compiler-    -> [ReadyComponent]-    -> [ComponentLocalBuildInfo]+  :: Compiler+  -> [ReadyComponent]+  -> [ComponentLocalBuildInfo] mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs   where     internalUnits = Set.fromList (map rc_uid rcs)     isInternal x = Set.member x internalUnits     go rc =       case rc_component rc of-      CLib lib ->-        let convModuleExport (modname', (Module uid modname))-              | this_uid == unDefUnitId uid-              , modname' == modname-              = Installed.ExposedModule modname' Nothing-              | otherwise-              = Installed.ExposedModule modname'-                  (Just (OpenModule (DefiniteUnitId uid) modname))-            convOpenModuleExport (modname', modu@(OpenModule uid modname))-              | uid == this_open_uid-              , modname' == modname-              = Installed.ExposedModule modname' Nothing-              | otherwise-              = Installed.ExposedModule modname' (Just modu)-            convOpenModuleExport (_, OpenModuleVar _)-                = error "convOpenModuleExport: top-level modvar"-            exports =+        CLib lib ->+          let convModuleExport (modname', (Module uid modname))+                | this_uid == unDefUnitId uid+                , modname' == modname =+                    Installed.ExposedModule modname' Nothing+                | otherwise =+                    Installed.ExposedModule+                      modname'+                      (Just (OpenModule (DefiniteUnitId uid) modname))+              convOpenModuleExport (modname', modu@(OpenModule uid modname))+                | uid == this_open_uid+                , modname' == modname =+                    Installed.ExposedModule modname' Nothing+                | otherwise =+                    Installed.ExposedModule modname' (Just modu)+              convOpenModuleExport (_, OpenModuleVar _) =+                error "convOpenModuleExport: top-level modvar"+              exports =                 -- Loses invariants                 case rc_i rc of-                    Left indefc -> map convOpenModuleExport-                                 $ Map.toList (indefc_provides indefc)-                    Right instc -> map convModuleExport-                                 $ Map.toList (instc_provides instc)-            insts =+                  Left indefc ->+                    map convOpenModuleExport $+                      Map.toList (indefc_provides indefc)+                  Right instc ->+                    map convModuleExport $+                      Map.toList (instc_provides instc)+              insts =                 case rc_i rc of-                    Left indefc -> [ (m, OpenModuleVar m) | m <- indefc_requires indefc ]-                    Right instc -> [ (m, OpenModule (DefiniteUnitId uid') m')-                                   | (m, Module uid' m') <- instc_insts instc ]--            compat_name = MungedPackageName (packageName rc) (libName lib)-            compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid+                  Left indefc -> [(m, OpenModuleVar m) | m <- indefc_requires indefc]+                  Right instc ->+                    [ (m, OpenModule (DefiniteUnitId uid') m')+                    | (m, Module uid' m') <- instc_insts instc+                    ] -        in LibComponentLocalBuildInfo {-          componentPackageDeps = cpds,-          componentUnitId = this_uid,-          componentComponentId = this_cid,-          componentInstantiatedWith = insts,-          componentIsIndefinite_ = is_indefinite,-          componentLocalName = cname,-          componentInternalDeps = internal_deps,-          componentExeDeps = exe_deps,-          componentIncludes = includes,-          componentExposedModules = exports,-          componentIsPublic = rc_public rc,-          componentCompatPackageKey = compat_key,-          componentCompatPackageName = compat_name-        }-      CFLib _ ->-        FLibComponentLocalBuildInfo {-          componentUnitId = this_uid,-          componentComponentId = this_cid,-          componentLocalName = cname,-          componentPackageDeps = cpds,-          componentExeDeps = exe_deps,-          componentInternalDeps = internal_deps,-          componentIncludes = includes-        }-      CExe _ ->-        ExeComponentLocalBuildInfo {-          componentUnitId = this_uid,-          componentComponentId = this_cid,-          componentLocalName = cname,-          componentPackageDeps = cpds,-          componentExeDeps = exe_deps,-          componentInternalDeps = internal_deps,-          componentIncludes = includes-        }-      CTest _ ->-        TestComponentLocalBuildInfo {-          componentUnitId = this_uid,-          componentComponentId = this_cid,-          componentLocalName = cname,-          componentPackageDeps = cpds,-          componentExeDeps = exe_deps,-          componentInternalDeps = internal_deps,-          componentIncludes = includes-        }-      CBench _ ->-        BenchComponentLocalBuildInfo {-          componentUnitId = this_uid,-          componentComponentId = this_cid,-          componentLocalName = cname,-          componentPackageDeps = cpds,-          componentExeDeps = exe_deps,-          componentInternalDeps = internal_deps,-          componentIncludes = includes-        }-     where-      this_uid      = rc_uid rc-      this_open_uid = rc_open_uid rc-      this_cid      = rc_cid rc-      cname = componentName (rc_component rc)-      cpds = rc_depends rc-      exe_deps = map ann_id $ rc_exe_deps rc-      is_indefinite =-        case rc_i rc of+              compat_name = MungedPackageName (packageName rc) (libName lib)+              compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid+           in LibComponentLocalBuildInfo+                { componentPackageDeps = cpds+                , componentUnitId = this_uid+                , componentComponentId = this_cid+                , componentInstantiatedWith = insts+                , componentIsIndefinite_ = is_indefinite+                , componentLocalName = cname+                , componentInternalDeps = internal_deps+                , componentExeDeps = exe_deps+                , componentIncludes = includes+                , componentExposedModules = exports+                , componentIsPublic = rc_public rc+                , componentCompatPackageKey = compat_key+                , componentCompatPackageName = compat_name+                }+        CFLib _ ->+          FLibComponentLocalBuildInfo+            { componentUnitId = this_uid+            , componentComponentId = this_cid+            , componentLocalName = cname+            , componentPackageDeps = cpds+            , componentExeDeps = exe_deps+            , componentInternalDeps = internal_deps+            , componentIncludes = includes+            }+        CExe _ ->+          ExeComponentLocalBuildInfo+            { componentUnitId = this_uid+            , componentComponentId = this_cid+            , componentLocalName = cname+            , componentPackageDeps = cpds+            , componentExeDeps = exe_deps+            , componentInternalDeps = internal_deps+            , componentIncludes = includes+            }+        CTest _ ->+          TestComponentLocalBuildInfo+            { componentUnitId = this_uid+            , componentComponentId = this_cid+            , componentLocalName = cname+            , componentPackageDeps = cpds+            , componentExeDeps = exe_deps+            , componentInternalDeps = internal_deps+            , componentIncludes = includes+            }+        CBench _ ->+          BenchComponentLocalBuildInfo+            { componentUnitId = this_uid+            , componentComponentId = this_cid+            , componentLocalName = cname+            , componentPackageDeps = cpds+            , componentExeDeps = exe_deps+            , componentInternalDeps = internal_deps+            , componentIncludes = includes+            }+      where+        this_uid = rc_uid rc+        this_open_uid = rc_open_uid rc+        this_cid = rc_cid rc+        cname = componentName (rc_component rc)+        cpds = rc_depends rc+        exe_deps = map ann_id $ rc_exe_deps rc+        is_indefinite =+          case rc_i rc of             Left _ -> True             Right _ -> False-      includes =-        map (\ci -> (ci_id ci, ci_renaming ci)) $+        includes =+          map (\ci -> (ci_id ci, ci_renaming ci)) $             case rc_i rc of-                Left indefc ->-                    indefc_includes indefc-                Right instc ->-                    map (\ci -> ci { ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci) })-                        (instc_includes instc)-      internal_deps = filter isInternal (nodeNeighbors rc)+              Left indefc ->+                indefc_includes indefc+              Right instc ->+                map+                  (\ci -> ci{ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci)})+                  (instc_includes instc)+        internal_deps = filter isInternal (nodeNeighbors rc)
src/Distribution/Backpack/ConfiguredComponent.hs view
@@ -1,80 +1,66 @@-{-# LANGUAGE PatternGuards #-} -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.ConfiguredComponent (-    ConfiguredComponent(..),-    cc_name,-    cc_cid,-    cc_pkgid,-    toConfiguredComponent,-    toConfiguredComponents,-    dispConfiguredComponent,--    ConfiguredComponentMap,-    extendConfiguredComponentMap,--    -- TODO: Should go somewhere else-    newPackageDepsBehaviour-) where+module Distribution.Backpack.ConfiguredComponent+  ( ConfiguredComponent (..)+  , cc_name+  , cc_cid+  , cc_pkgid+  , toConfiguredComponent+  , toConfiguredComponents+  , dispConfiguredComponent+  , ConfiguredComponentMap+  , extendConfiguredComponentMap+  -- TODO: Should go somewhere else+  , newPackageDepsBehaviour+  ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>))+import Prelude ()  import Distribution.Backpack.Id  import Distribution.CabalSpecVersion-import Distribution.Types.AnnotatedId-import Distribution.Types.Dependency-import Distribution.Types.ExeDependency-import Distribution.Types.IncludeRenaming-import Distribution.Types.ComponentId-import Distribution.Types.PackageId-import Distribution.Types.PackageName-import Distribution.Types.Mixin-import Distribution.Types.ComponentName-import Distribution.Types.LibraryName-import Distribution.Types.ComponentInclude import Distribution.Package import Distribution.PackageDescription import Distribution.Simple.BuildToolDepends-import Distribution.Simple.Setup as Setup+import Distribution.Simple.Flag (Flag) import Distribution.Simple.LocalBuildInfo+import Distribution.Types.AnnotatedId+import Distribution.Types.ComponentInclude+import Distribution.Utils.Generic import Distribution.Utils.LogProgress import Distribution.Utils.MapAccum-import Distribution.Utils.Generic  import Control.Monad+import qualified Data.Map as Map import qualified Data.Set as Set import qualified Distribution.Compat.NonEmptySet as NonEmptySet-import qualified Data.Map as Map import Distribution.Pretty-import Text.PrettyPrint (Doc, hang, text, vcat, hsep, quotes, ($$))+import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($$)) import qualified Text.PrettyPrint as PP  -- | A configured component, we know exactly what its 'ComponentId' is, -- and the 'ComponentId's of the things it depends on.-data ConfiguredComponent-    = ConfiguredComponent {-        -- | Unique identifier of component, plus extra useful info.-        cc_ann_id :: AnnotatedId ComponentId,-        -- | The fragment of syntax from the Cabal file describing this-        -- component.-        cc_component :: Component,-        -- | Is this the public library component of the package?-        -- (If we invoke Setup with an instantiation, this is the-        -- component the instantiation applies to.)-        -- Note that in one-component configure mode, this is-        -- always True, because any component is the "public" one.)-        cc_public :: Bool,-        -- | Dependencies on executables from @build-tools@ and-        -- @build-tool-depends@.-        cc_exe_deps :: [AnnotatedId ComponentId],-        -- | The mixins of this package, including both explicit (from-        -- the @mixins@ field) and implicit (from @build-depends@).  Not-        -- mix-in linked yet; component configuration only looks at-        -- 'ComponentId's.-        cc_includes :: [ComponentInclude ComponentId IncludeRenaming]-      }-+data ConfiguredComponent = ConfiguredComponent+  { cc_ann_id :: AnnotatedId ComponentId+  -- ^ Unique identifier of component, plus extra useful info.+  , cc_component :: Component+  -- ^ The fragment of syntax from the Cabal file describing this+  -- component.+  , cc_public :: Bool+  -- ^ Is this the public library component of the package?+  -- (If we invoke Setup with an instantiation, this is the+  -- component the instantiation applies to.)+  -- Note that in one-component configure mode, this is+  -- always True, because any component is the "public" one.)+  , cc_exe_deps :: [AnnotatedId ComponentId]+  -- ^ Dependencies on executables from @build-tools@ and+  -- @build-tool-depends@.+  , cc_includes :: [ComponentInclude ComponentId IncludeRenaming]+  -- ^ The mixins of this package, including both explicit (from+  -- the @mixins@ field) and implicit (from @build-depends@).  Not+  -- mix-in linked yet; component configuration only looks at+  -- 'ComponentId's.+  }  -- | Uniquely identifies a configured component. cc_cid :: ConfiguredComponent -> ComponentId@@ -93,110 +79,132 @@ -- | Pretty-print a 'ConfiguredComponent'. dispConfiguredComponent :: ConfiguredComponent -> Doc dispConfiguredComponent cc =-    hang (text "component" <+> pretty (cc_cid cc)) 4-         (vcat [ hsep $ [ text "include"-                        , pretty (ci_id incl), pretty (ci_renaming incl) ]-               | incl <- cc_includes cc-               ])+  hang+    (text "component" <+> pretty (cc_cid cc))+    4+    ( vcat+        [ hsep $+          [ text "include"+          , pretty (ci_id incl)+          , pretty (ci_renaming incl)+          ]+        | incl <- cc_includes cc+        ]+    )  -- | Construct a 'ConfiguredComponent', given that the 'ComponentId' -- and library/executable dependencies are known.  The primary -- work this does is handling implicit @backpack-include@ fields. mkConfiguredComponent-    :: PackageDescription-    -> ComponentId-    -> [AnnotatedId ComponentId] -- lib deps-    -> [AnnotatedId ComponentId] -- exe deps-    -> Component-    -> LogProgress ConfiguredComponent+  :: PackageDescription+  -> ComponentId+  -> [AnnotatedId ComponentId] -- lib deps+  -> [AnnotatedId ComponentId] -- exe deps+  -> Component+  -> LogProgress ConfiguredComponent mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do-    -- Resolve each @mixins@ into the actual dependency-    -- from @lib_deps@.-    explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do-        aid <- case Map.lookup (pn, CLibName ln) deps_map of-                Nothing ->-                    dieProgress $-                    text "Mix-in refers to non-existent library" <+>-                    quotes (pretty pn <<>> prettyLN ln) $$-                    text "(did you forget to add the package to build-depends?)"-                Just r  -> return r-        return ComponentInclude {-                ci_ann_id   = aid,-                ci_renaming = rns,-                ci_implicit = False-            }+  -- Resolve each @mixins@ into the actual dependency+  -- from @lib_deps@.+  explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do+    aid <- case Map.lookup (pn, CLibName ln) deps_map of+      Nothing ->+        dieProgress $+          text "Mix-in refers to non-existent library"+            <+> quotes (pretty pn <<>> prettyLN ln)+            $$ text "(did you forget to add the package to build-depends?)"+      Just r -> return r+    return+      ComponentInclude+        { ci_ann_id = aid+        , ci_renaming = rns+        , ci_implicit = False+        } -        -- Any @build-depends@ which is not explicitly mentioned in-        -- @backpack-include@ is converted into an "implicit" include.-    let used_explicitly = Set.fromList (map ci_id explicit_includes)-        implicit_includes-            = map (\aid -> ComponentInclude {-                                ci_ann_id = aid,-                                ci_renaming = defaultIncludeRenaming,-                                ci_implicit = True-                            })-            $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps+  -- Any @build-depends@ which is not explicitly mentioned in+  -- @backpack-include@ is converted into an "implicit" include.+  let used_explicitly = Set.fromList (map ci_id explicit_includes)+      implicit_includes =+        map+          ( \aid ->+              ComponentInclude+                { ci_ann_id = aid+                , ci_renaming = defaultIncludeRenaming+                , ci_implicit = True+                }+          )+          $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps -    return ConfiguredComponent {-            cc_ann_id = AnnotatedId {-                    ann_id = this_cid,-                    ann_pid = package pkg_descr,-                    ann_cname = componentName component-                },-            cc_component = component,-            cc_public = is_public,-            cc_exe_deps = exe_deps,-            cc_includes = explicit_includes ++ implicit_includes-        }+  return+    ConfiguredComponent+      { cc_ann_id =+          AnnotatedId+            { ann_id = this_cid+            , ann_pid = package pkg_descr+            , ann_cname = componentName component+            }+      , cc_component = component+      , cc_public = is_public+      , cc_exe_deps = exe_deps+      , cc_includes = explicit_includes ++ implicit_includes+      }   where     bi :: BuildInfo     bi = componentBuildInfo component      prettyLN :: LibraryName -> Doc-    prettyLN LMainLibName    = PP.empty+    prettyLN LMainLibName = PP.empty     prettyLN (LSubLibName n) = PP.colon <<>> pretty n      deps_map :: Map (PackageName, ComponentName) (AnnotatedId ComponentId)-    deps_map = Map.fromList [ ((packageName dep, ann_cname dep), dep)-                            | dep <- lib_deps ]+    deps_map =+      Map.fromList+        [ ((packageName dep, ann_cname dep), dep)+        | dep <- lib_deps+        ]      is_public = componentName component == CLibName LMainLibName  type ConfiguredComponentMap =-        Map PackageName (Map ComponentName (AnnotatedId ComponentId))+  Map PackageName (Map ComponentName (AnnotatedId ComponentId))  toConfiguredComponent-    :: PackageDescription-    -> ComponentId-    -> ConfiguredComponentMap-    -> ConfiguredComponentMap-    -> Component-    -> LogProgress ConfiguredComponent+  :: PackageDescription+  -> ComponentId+  -> ConfiguredComponentMap+  -> ConfiguredComponentMap+  -> Component+  -> LogProgress ConfiguredComponent toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do-    lib_deps <--        if newPackageDepsBehaviour pkg_descr-            then fmap concat $ forM (targetBuildDepends bi) $-                 \(Dependency name _ sublibs) -> do-                    pkg <- case Map.lookup name lib_dep_map of+  lib_deps <-+    if newPackageDepsBehaviour pkg_descr+      then fmap concat $+        forM (targetBuildDepends bi) $+          \(Dependency name _ sublibs) -> do+            case Map.lookup name lib_dep_map of+              Nothing ->+                dieProgress $+                  text "Dependency on unbuildable"+                    <+> text "package"+                    <+> pretty name+              Just pkg -> do+                -- Return all library components+                forM (NonEmptySet.toList sublibs) $ \lib ->+                  let comp = CLibName lib+                   in case Map.lookup comp pkg of                         Nothing ->-                            dieProgress $-                                text "Dependency on unbuildable" <+>-                                text "package" <+> pretty name-                        Just p -> return p-                    -- Return all library components-                    forM (NonEmptySet.toList sublibs) $ \lib ->-                        let comp = CLibName lib in-                        case Map.lookup comp pkg of-                            Nothing ->-                                dieProgress $-                                    text "Dependency on unbuildable" <+>-                                    text (showLibraryName lib) <+>-                                    text "from" <+> pretty name-                            Just v -> return v-            else return old_style_lib_deps-    mkConfiguredComponent-       pkg_descr this_cid-       lib_deps exe_deps component+                          dieProgress $+                            text "Dependency on unbuildable"+                              <+> text (showLibraryName lib)+                              <+> text "from"+                              <+> pretty name+                        Just v -> return v+      else return old_style_lib_deps+  mkConfiguredComponent+    pkg_descr+    this_cid+    lib_deps+    exe_deps+    component   where     bi = componentBuildInfo component     -- lib_dep_map contains a mix of internal and external deps.@@ -206,62 +214,84 @@     -- this is not supported by old-style deps behavior     -- because it would imply a cyclic dependency for the     -- library itself.-    old_style_lib_deps = [ e-                         | (pn, comp_map) <- Map.toList lib_dep_map-                         , pn /= packageName pkg_descr-                         , (cn, e) <- Map.toList comp_map-                         , cn == CLibName LMainLibName ]+    old_style_lib_deps =+      [ e+      | (pn, comp_map) <- Map.toList lib_dep_map+      , pn /= packageName pkg_descr+      , (cn, e) <- Map.toList comp_map+      , cn == CLibName LMainLibName+      ]     -- We have to nub here, because 'getAllToolDependencies' may return     -- duplicates (see #4986).  (NB: This is not needed for lib_deps,     -- since those elaborate into includes, for which there explicitly     -- may be multiple instances of a package)-    exe_deps = ordNub $+    exe_deps =+      ordNub $         [ exe         | ExeDependency pn cn _ <- getAllToolDependencies pkg_descr bi-        -- The error suppression here is important, because in general+        , -- The error suppression here is important, because in general         -- we won't know about external dependencies (e.g., 'happy')         -- which the package is attempting to use (those deps are only         -- fed in when cabal-install uses this codepath.)         -- TODO: Let cabal-install request errors here-        , Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map]+        Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map]         ]  -- | Also computes the 'ComponentId', and sets cc_public if necessary. -- This is Cabal-only; cabal-install won't use this. toConfiguredComponent'-    :: Bool -- use_external_internal_deps-    -> FlagAssignment-    -> PackageDescription-    -> Bool -- deterministic-    -> Flag String      -- configIPID (todo: remove me)-    -> Flag ComponentId -- configCID-    -> ConfiguredComponentMap-    -> Component-    -> LogProgress ConfiguredComponent-toConfiguredComponent' use_external_internal_deps flags-                pkg_descr deterministic ipid_flag cid_flag-                dep_map component = do-    cc <- toConfiguredComponent-                pkg_descr this_cid-                dep_map dep_map component-    return $ if use_external_internal_deps-                then cc { cc_public = True }-                else cc-  where-    -- TODO: pass component names to it too!-    this_cid = computeComponentId deterministic ipid_flag cid_flag-                (package pkg_descr) (componentName component) (Just (deps, flags))-    deps = [ ann_id aid | m <- Map.elems dep_map-                        , aid <- Map.elems m ]+  :: Bool -- use_external_internal_deps+  -> FlagAssignment+  -> PackageDescription+  -> Bool -- deterministic+  -> Flag String -- configIPID (todo: remove me)+  -> Flag ComponentId -- configCID+  -> ConfiguredComponentMap+  -> Component+  -> LogProgress ConfiguredComponent+toConfiguredComponent'+  use_external_internal_deps+  flags+  pkg_descr+  deterministic+  ipid_flag+  cid_flag+  dep_map+  component = do+    cc <-+      toConfiguredComponent+        pkg_descr+        this_cid+        dep_map+        dep_map+        component+    return $+      if use_external_internal_deps+        then cc{cc_public = True}+        else cc+    where+      -- TODO: pass component names to it too!+      this_cid =+        computeComponentId+          deterministic+          ipid_flag+          cid_flag+          (package pkg_descr)+          (componentName component)+          (Just (deps, flags))+      deps =+        [ ann_id aid | m <- Map.elems dep_map, aid <- Map.elems m+        ]  extendConfiguredComponentMap-    :: ConfiguredComponent-    -> ConfiguredComponentMap-    -> ConfiguredComponentMap+  :: ConfiguredComponent+  -> ConfiguredComponentMap+  -> ConfiguredComponentMap extendConfiguredComponentMap cc =-    Map.insertWith Map.union-        (pkgName (cc_pkgid cc))-        (Map.singleton (cc_name cc) (cc_ann_id cc))+  Map.insertWith+    Map.union+    (pkgName (cc_pkgid cc))+    (Map.singleton (cc_name cc) (cc_ann_id cc))  -- Compute the 'ComponentId's for a graph of 'Component's.  The -- list of internal components must be topologically sorted@@ -273,31 +303,42 @@ -- be used to configure a component that depends on one version of a package for -- a library and another version for a build-tool. toConfiguredComponents-    :: Bool -- use_external_internal_deps-    -> FlagAssignment-    -> Bool -- deterministic-    -> Flag String -- configIPID-    -> Flag ComponentId -- configCID-    -> PackageDescription-    -> ConfiguredComponentMap-    -> [Component]-    -> LogProgress [ConfiguredComponent]+  :: Bool -- use_external_internal_deps+  -> FlagAssignment+  -> Bool -- deterministic+  -> Flag String -- configIPID+  -> Flag ComponentId -- configCID+  -> PackageDescription+  -> ConfiguredComponentMap+  -> [Component]+  -> LogProgress [ConfiguredComponent] toConfiguredComponents-    use_external_internal_deps flags deterministic ipid_flag cid_flag pkg_descr-    dep_map comps-    = fmap snd (mapAccumM go dep_map comps)-  where-    go m component = do-        cc <- toConfiguredComponent'-                        use_external_internal_deps flags pkg_descr-                        deterministic ipid_flag cid_flag-                        m component+  use_external_internal_deps+  flags+  deterministic+  ipid_flag+  cid_flag+  pkg_descr+  dep_map+  comps =+    fmap snd (mapAccumM go dep_map comps)+    where+      go m component = do+        cc <-+          toConfiguredComponent'+            use_external_internal_deps+            flags+            pkg_descr+            deterministic+            ipid_flag+            cid_flag+            m+            component         return (extendConfiguredComponentMap cc m, cc)  newPackageDepsBehaviourMinVersion :: CabalSpecVersion newPackageDepsBehaviourMinVersion = CabalSpecV1_8 - -- In older cabal versions, there was only one set of package dependencies for -- the whole package. In this version, we can have separate dependencies per -- target, but we only enable this behaviour if the minimum cabal version@@ -305,4 +346,4 @@ -- old behaviour. newPackageDepsBehaviour :: PackageDescription -> Bool newPackageDepsBehaviour pkg =-   specVersion pkg >= newPackageDepsBehaviourMinVersion+  specVersion pkg >= newPackageDepsBehaviourMinVersion
src/Distribution/Backpack/DescribeUnitId.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Rank2Types       #-}+{-# LANGUAGE Rank2Types #-}+ module Distribution.Backpack.DescribeUnitId where  import Distribution.Compat.Prelude@@ -36,26 +37,36 @@ -- | Print a Setup message stating (1) what operation we are doing, -- for (2) which component (with enough details to uniquely identify -- the build in question.)----setupMessage' :: Pretty a => Verbosity-             -> String            -- ^ Operation being done (capitalized), on:-             -> PackageIdentifier -- ^ Package-             -> ComponentName     -- ^ Component name-             -> Maybe [(ModuleName, a)] -- ^ Instantiation, if available.-                                        -- Polymorphic to take-                                        -- 'OpenModule' or 'Module'-             -> IO ()+setupMessage'+  :: Pretty a+  => Verbosity+  -> String+  -- ^ Operation being done (capitalized), on:+  -> PackageIdentifier+  -- ^ Package+  -> ComponentName+  -- ^ Component name+  -> Maybe [(ModuleName, a)]+  -- ^ Instantiation, if available.+  -- Polymorphic to take+  -- 'OpenModule' or 'Module'+  -> IO () setupMessage' verbosity msg pkgid cname mb_insts = withFrozenCallStack $ do-    noticeDoc verbosity $-      case mb_insts of-        Just insts | not (null insts) ->-          hang (msg_doc <+> text "instantiated with") 2-               (vcat [ pretty k <+> text "=" <+> pretty v-                     | (k,v) <- insts ]) $$-          for_doc-        _ ->-          msg_doc <+> for_doc-+  noticeDoc verbosity $+    case mb_insts of+      Just insts+        | not (null insts) ->+            hang+              (msg_doc <+> text "instantiated with")+              2+              ( vcat+                  [ pretty k <+> text "=" <+> pretty v+                  | (k, v) <- insts+                  ]+              )+              $$ for_doc+      _ ->+        msg_doc <+> for_doc   where     msg_doc = text msg <+> text (showComponentName cname)-    for_doc = text "for" <+> pretty pkgid <<>> text ".."+    for_doc = text "for" <+> pretty pkgid <<>> text "..."
src/Distribution/Backpack/FullUnitId.hs view
@@ -1,26 +1,27 @@ {-# LANGUAGE DeriveGeneric #-}-module Distribution.Backpack.FullUnitId (-    FullUnitId(..),-    FullDb,-    expandOpenUnitId,-    expandUnitId-) where +module Distribution.Backpack.FullUnitId+  ( FullUnitId (..)+  , FullDb+  , expandOpenUnitId+  , expandUnitId+  ) where+ import Distribution.Backpack-import Distribution.Types.ComponentId import Distribution.Compat.Prelude+import Distribution.Types.ComponentId  -- Unlike OpenUnitId, which could direct to a UnitId. data FullUnitId = FullUnitId ComponentId OpenModuleSubst-    deriving (Show, Generic)+  deriving (Show, Generic)  type FullDb = DefUnitId -> FullUnitId  expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId-expandOpenUnitId _db (IndefFullUnitId cid subst)-    = FullUnitId cid subst-expandOpenUnitId db (DefiniteUnitId uid)-    = expandUnitId db uid+expandOpenUnitId _db (IndefFullUnitId cid subst) =+  FullUnitId cid subst+expandOpenUnitId db (DefiniteUnitId uid) =+  expandUnitId db uid  expandUnitId :: FullDb -> DefUnitId -> FullUnitId expandUnitId db uid = db uid
src/Distribution/Backpack/Id.hs view
@@ -1,74 +1,87 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.Id(-    computeComponentId,-    computeCompatPackageKey,-) where+module Distribution.Backpack.Id+  ( computeComponentId+  , computeCompatPackageKey+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Types.UnqualComponentName-import Distribution.Simple.Compiler import Distribution.PackageDescription-import Distribution.Simple.Setup as Setup+import Distribution.Simple.Compiler+import Distribution.Simple.Flag (Flag, pattern Flag, pattern NoFlag) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo import Distribution.Types.ComponentId-import Distribution.Types.UnitId import Distribution.Types.MungedPackageName+import Distribution.Types.UnitId import Distribution.Utils.Base62 import Distribution.Version +import Distribution.Parsec (simpleParsec) import Distribution.Pretty-    ( prettyShow )-import Distribution.Parsec ( simpleParsec )+  ( prettyShow+  )  -- | This method computes a default, "good enough" 'ComponentId' -- for a package.  The intent is that cabal-install (or the user) will -- specify a more detailed IPID via the @--ipid@ flag if necessary. computeComponentId-    :: Bool -- deterministic mode-    -> Flag String-    -> Flag ComponentId-    -> PackageIdentifier-    -> ComponentName-    -- This is used by cabal-install's legacy codepath-    -> Maybe ([ComponentId], FlagAssignment)-    -> ComponentId+  :: Bool -- deterministic mode+  -> Flag String+  -> Flag ComponentId+  -> PackageIdentifier+  -> ComponentName+  -- This is used by cabal-install's legacy codepath+  -> Maybe ([ComponentId], FlagAssignment)+  -> ComponentId computeComponentId deterministic mb_ipid mb_cid pid cname mb_details =-    -- show is found to be faster than intercalate and then replacement of-    -- special character used in intercalating. We cannot simply hash by-    -- doubly concating list, as it just flatten out the nested list, so-    -- different sources can produce same hash-    let hash_suffix-            | Just (dep_ipids, flags) <- mb_details-            = "-" ++ hashToBase62+  -- show is found to be faster than intercalate and then replacement of+  -- special character used in intercalating. We cannot simply hash by+  -- doubly concatenating list, as it just flatten out the nested list, so+  -- different sources can produce same hash+  let hash_suffix+        | Just (dep_ipids, flags) <- mb_details =+            "-"+              ++ hashToBase62                 -- For safety, include the package + version here                 -- for GHC 7.10, where just the hash is used as                 -- the package key-                    (    prettyShow pid-                      ++ show dep_ipids-                      ++ show flags     )-            | otherwise = ""-        generated_base = prettyShow pid ++ hash_suffix-        explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env-                                                    (toPathTemplate cid0))-            -- Hack to reuse install dirs machinery-            -- NB: no real IPID available at this point-          where env = packageTemplateEnv pid (mkUnitId "")-        actual_base = case mb_ipid of-                        Flag ipid0 -> explicit_base ipid0-                        NoFlag | deterministic -> prettyShow pid-                               | otherwise     -> generated_base-    in case mb_cid of-          Flag cid -> cid-          NoFlag -> mkComponentId $ actual_base-                        ++ (case componentNameString cname of-                                Nothing -> ""-                                Just s -> "-" ++ unUnqualComponentName s)+                ( prettyShow pid+                    ++ show dep_ipids+                    ++ show flags+                )+        | otherwise = ""+      generated_base = prettyShow pid ++ hash_suffix+      explicit_base cid0 =+        fromPathTemplate+          ( InstallDirs.substPathTemplate+              env+              (toPathTemplate cid0)+          )+        where+          -- Hack to reuse install dirs machinery+          -- NB: no real IPID available at this point+          env = packageTemplateEnv pid (mkUnitId "")+      actual_base = case mb_ipid of+        Flag ipid0 -> explicit_base ipid0+        NoFlag+          | deterministic -> prettyShow pid+          | otherwise -> generated_base+   in case mb_cid of+        Flag cid -> cid+        NoFlag ->+          mkComponentId $+            actual_base+              ++ ( case componentNameString cname of+                    Nothing -> ""+                    Just s -> "-" ++ unUnqualComponentName s+                 )  -- | In GHC 8.0, the string we pass to GHC to use for symbol -- names for a package can be an arbitrary, IPID-compatible string.@@ -116,30 +129,29 @@ -- --      * For sub-components, we rehash the IPID into the correct format --        and pass that.--- computeCompatPackageKey-    :: Compiler-    -> MungedPackageName-    -> Version-    -> UnitId-    -> String+  :: Compiler+  -> MungedPackageName+  -> Version+  -> UnitId+  -> String computeCompatPackageKey comp pkg_name pkg_version uid-    | not (packageKeySupported comp || unitIdSupported comp)-    = prettyShow pkg_name ++ "-" ++ prettyShow pkg_version-    | not (unifiedIPIDRequired comp) =-        let str = unUnitId uid -- assume no Backpack support-            mb_verbatim_key-                = case simpleParsec str :: Maybe PackageId of-                    -- Something like 'foo-0.1', use it verbatim.-                    -- (NB: hash tags look like tags, so they are parsed,-                    -- so the extra equality check tests if a tag was dropped.)-                    Just pid0 | prettyShow pid0 == str -> Just str-                    _ -> Nothing-            mb_truncated_key-                = let cand = reverse (takeWhile isAlphaNum (reverse str))-                  in if length cand == 22 && all isAlphaNum cand-                        then Just cand-                        else Nothing-            rehashed_key = hashToBase62 str-        in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key)-    | otherwise = prettyShow uid+  | not (packageKeySupported comp || unitIdSupported comp) =+      prettyShow pkg_name ++ "-" ++ prettyShow pkg_version+  | not (unifiedIPIDRequired comp) =+      let str = unUnitId uid -- assume no Backpack support+          mb_verbatim_key =+            case simpleParsec str :: Maybe PackageId of+              -- Something like 'foo-0.1', use it verbatim.+              -- (NB: hash tags look like tags, so they are parsed,+              -- so the extra equality check tests if a tag was dropped.)+              Just pid0 | prettyShow pid0 == str -> Just str+              _ -> Nothing+          mb_truncated_key =+            let cand = reverse (takeWhile isAlphaNum (reverse str))+             in if length cand == 22 && all isAlphaNum cand+                  then Just cand+                  else Nothing+          rehashed_key = hashToBase62 str+       in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key)+  | otherwise = prettyShow uid
src/Distribution/Backpack/LinkedComponent.hs view
@@ -1,82 +1,76 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.LinkedComponent (-    LinkedComponent(..),-    lc_insts,-    lc_uid,-    lc_cid,-    lc_pkgid,-    toLinkedComponent,-    toLinkedComponents,-    dispLinkedComponent,-    LinkedComponentMap,-    extendLinkedComponentMap,-) where+module Distribution.Backpack.LinkedComponent+  ( LinkedComponent (..)+  , lc_insts+  , lc_uid+  , lc_cid+  , lc_pkgid+  , toLinkedComponent+  , toLinkedComponents+  , dispLinkedComponent+  , LinkedComponentMap+  , extendLinkedComponentMap+  ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>))+import Prelude ()  import Distribution.Backpack-import Distribution.Backpack.FullUnitId import Distribution.Backpack.ConfiguredComponent+import Distribution.Backpack.FullUnitId+import Distribution.Backpack.MixLink+import Distribution.Backpack.ModuleScope import Distribution.Backpack.ModuleShape import Distribution.Backpack.PreModuleShape-import Distribution.Backpack.ModuleScope import Distribution.Backpack.UnifyM-import Distribution.Backpack.MixLink import Distribution.Utils.MapAccum -import Distribution.Types.AnnotatedId-import Distribution.Types.ComponentName-import Distribution.Types.ModuleReexport-import Distribution.Types.ModuleRenaming-import Distribution.Types.IncludeRenaming-import Distribution.Types.ComponentInclude-import Distribution.Types.ComponentId-import Distribution.Types.PackageId+import Distribution.ModuleName import Distribution.Package import Distribution.PackageDescription-import Distribution.ModuleName import Distribution.Simple.LocalBuildInfo-import Distribution.Verbosity+import Distribution.Types.AnnotatedId+import Distribution.Types.ComponentInclude import Distribution.Utils.LogProgress+import Distribution.Verbosity -import qualified Data.Set as Set import qualified Data.Map as Map+import qualified Data.Set as Set import Distribution.Pretty (pretty)-import Text.PrettyPrint (Doc, hang, text, vcat, ($+$), hsep, quotes)+import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($+$))  -- | A linked component is a component that has been mix-in linked, at -- which point we have determined how all the dependencies of the -- component are explicitly instantiated (in the form of an OpenUnitId). -- 'ConfiguredComponent' is mix-in linked into 'LinkedComponent', which -- is then instantiated into 'ReadyComponent'.-data LinkedComponent-    = LinkedComponent {-        -- | Uniquely identifies linked component-        lc_ann_id :: AnnotatedId ComponentId,-        -- | Corresponds to 'cc_component'.-        lc_component :: Component,-        -- | @build-tools@ and @build-tool-depends@ dependencies.-        -- Corresponds to 'cc_exe_deps'.-        lc_exe_deps :: [AnnotatedId OpenUnitId],-        -- | Is this the public library of a package?  Corresponds to-        -- 'cc_public'.-        lc_public :: Bool,-        -- | Corresponds to 'cc_includes', but (1) this does not contain-        -- includes of signature packages (packages with no exports),-        -- and (2) the 'ModuleRenaming' for requirements (stored in-        -- 'IncludeRenaming') has been removed, as it is reflected in-        -- 'OpenUnitId'.)-        lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming],-        -- | Like 'lc_includes', but this specifies includes on-        -- signature packages which have no exports.-        lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming],-        -- | The module shape computed by mix-in linking.  This is-        -- newly computed from 'ConfiguredComponent'-        lc_shape :: ModuleShape-      }+data LinkedComponent = LinkedComponent+  { lc_ann_id :: AnnotatedId ComponentId+  -- ^ Uniquely identifies linked component+  , lc_component :: Component+  -- ^ Corresponds to 'cc_component'.+  , lc_exe_deps :: [AnnotatedId OpenUnitId]+  -- ^ @build-tools@ and @build-tool-depends@ dependencies.+  -- Corresponds to 'cc_exe_deps'.+  , lc_public :: Bool+  -- ^ Is this the public library of a package?  Corresponds to+  -- 'cc_public'.+  , lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]+  -- ^ Corresponds to 'cc_includes', but (1) this does not contain+  -- includes of signature packages (packages with no exports),+  -- and (2) the 'ModuleRenaming' for requirements (stored in+  -- 'IncludeRenaming') has been removed, as it is reflected in+  -- 'OpenUnitId'.)+  , lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming]+  -- ^ Like 'lc_includes', but this specifies includes on+  -- signature packages which have no exports.+  , lc_shape :: ModuleShape+  -- ^ The module shape computed by mix-in linking.  This is+  -- newly computed from 'ConfiguredComponent'+  }  -- | Uniquely identifies a 'LinkedComponent'.  Corresponds to -- 'cc_cid'.@@ -96,94 +90,125 @@ -- | The instantiation of 'lc_uid'; this always has the invariant -- that it is a mapping from a module name @A@ to @<A>@ (the hole A). lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)]-lc_insts lc = [ (req, OpenModuleVar req)-              | req <- Set.toList (modShapeRequires (lc_shape lc)) ]+lc_insts lc =+  [ (req, OpenModuleVar req)+  | req <- Set.toList (modShapeRequires (lc_shape lc))+  ]  dispLinkedComponent :: LinkedComponent -> Doc dispLinkedComponent lc =-    hang (text "unit" <+> pretty (lc_uid lc)) 4 $-         vcat [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl)-              | incl <- lc_includes lc ]-            $+$-         vcat [ text "signature include" <+> pretty (ci_id incl)-              | incl <- lc_sig_includes lc ]-            $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc))+  hang (text "unit" <+> pretty (lc_uid lc)) 4 $+    vcat+      [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl)+      | incl <- lc_includes lc+      ]+      $+$ vcat+        [ text "signature include" <+> pretty (ci_id incl)+        | incl <- lc_sig_includes lc+        ]+      $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc))  instance Package LinkedComponent where-    packageId = lc_pkgid+  packageId = lc_pkgid  toLinkedComponent-    :: Verbosity-    -> FullDb-    -> PackageId-    -> LinkedComponentMap-    -> ConfiguredComponent-    -> LogProgress LinkedComponent-toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {-    cc_ann_id = aid@AnnotatedId { ann_id = this_cid },-    cc_component = component,-    cc_exe_deps = exe_deps,-    cc_public = is_public,-    cc_includes = cid_includes-   } = do+  :: Verbosity+  -> Bool+  -- ^ Whether there are any "promised" package dependencies which we won't find already installed.+  -> FullDb+  -> PackageId+  -> LinkedComponentMap+  -> ConfiguredComponent+  -> LogProgress LinkedComponent+toLinkedComponent+  verbosity+  anyPromised+  db+  this_pid+  pkg_map+  ConfiguredComponent+    { cc_ann_id = aid@AnnotatedId{ann_id = this_cid}+    , cc_component = component+    , cc_exe_deps = exe_deps+    , cc_public = is_public+    , cc_includes = cid_includes+    } = do     let-        -- The explicitly specified requirements, provisions and-        -- reexports from the Cabal file.  These are only non-empty for-        -- libraries; everything else is trivial.-        (src_reqs      :: [ModuleName],-         src_provs     :: [ModuleName],-         src_reexports :: [ModuleReexport]) =-            case component of-                CLib lib -> (signatures lib,-                             exposedModules lib,-                             reexportedModules lib)-                _ -> ([], [], [])-        src_hidden = otherModules (componentBuildInfo component)+      -- The explicitly specified requirements, provisions and+      -- reexports from the Cabal file.  These are only non-empty for+      -- libraries; everything else is trivial.+      ( src_reqs :: [ModuleName]+        , src_provs :: [ModuleName]+        , src_reexports :: [ModuleReexport]+        ) =+          case component of+            CLib lib ->+              ( signatures lib+              , exposedModules lib+              , reexportedModules lib+              )+            _ -> ([], [], [])+      src_hidden = otherModules (componentBuildInfo component) -        -- Take each included ComponentId and resolve it into an-        -- *unlinked* unit identity.  We will use unification (relying-        -- on the ModuleShape) to resolve these into linked identities.-        unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]-        unlinked_includes = [ ComponentInclude (fmap lookupUid dep_aid) rns i-                            | ComponentInclude dep_aid rns i <- cid_includes ]+      -- Take each included ComponentId and resolve it into an+      -- \*unlinked* unit identity.  We will use unification (relying+      -- on the ModuleShape) to resolve these into linked identities.+      unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]+      unlinked_includes =+        [ ComponentInclude (fmap lookupUid dep_aid) rns i+        | ComponentInclude dep_aid rns i <- cid_includes+        ] -        lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)-        lookupUid cid = fromMaybe (error "linkComponent: lookupUid")-                                    (Map.lookup cid pkg_map)+      lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)+      lookupUid cid =+        fromMaybe+          (error "linkComponent: lookupUid")+          (Map.lookup cid pkg_map)      let orErr (Right x) = return x         orErr (Left [err]) = dieProgress err         orErr (Left errs) = do-            dieProgress (vcat (intersperse (text "") -- double newline!-                                [ hang (text "-") 2 err | err <- errs]))+          dieProgress+            ( vcat+                ( intersperse+                    (text "") -- double newline!+                    [hang (text "-") 2 err | err <- errs]+                )+            )      -- Pre-shaping-    let pre_shape = mixLinkPreModuleShape $-            PreModuleShape {-                preModShapeProvides = Set.fromList (src_provs ++ src_hidden),-                preModShapeRequires = Set.fromList src_reqs-            } : [ renamePreModuleShape (toPreModuleShape sh) rns-                | ComponentInclude (AnnotatedId { ann_id = (_, sh) }) rns _ <- unlinked_includes ]-        reqs  = preModShapeRequires pre_shape-        insts = [ (req, OpenModuleVar req)-                | req <- Set.toList reqs ]+    let pre_shape =+          mixLinkPreModuleShape $+            PreModuleShape+              { preModShapeProvides = Set.fromList (src_provs ++ src_hidden)+              , preModShapeRequires = Set.fromList src_reqs+              }+              : [ renamePreModuleShape (toPreModuleShape sh) rns+                | ComponentInclude (AnnotatedId{ann_id = (_, sh)}) rns _ <- unlinked_includes+                ]+        reqs = preModShapeRequires pre_shape+        insts =+          [ (req, OpenModuleVar req)+          | req <- Set.toList reqs+          ]         this_uid = IndefFullUnitId this_cid . Map.fromList $ insts      -- OK, actually do unification     -- TODO: the unification monad might return errors, in which     -- case we have to deal.  Use monadic bind for now.-    (linked_shape0  :: ModuleScope,-     linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming],-     linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming])-      <- orErr $ runUnifyM verbosity this_cid db $ do+    ( linked_shape0 :: ModuleScope+      , linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]+      , linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]+      ) <-+      orErr $ runUnifyM verbosity this_cid db $ do         -- The unification monad is implemented using mutable         -- references.  Thus, we must convert our *pure* data         -- structures into mutable ones to perform unification.          let convertMod :: (ModuleName -> ModuleSource) -> ModuleName -> UnifyM s (ModuleScopeU s)             convertMod from m = do-                m_u <- convertModule (OpenModule this_uid m)-                return (Map.singleton m [WithSource (from m) m_u], Map.empty)+              m_u <- convertModule (OpenModule this_uid m)+              return (Map.singleton m [WithSource (from m) m_u], Map.empty)         -- Handle 'exposed-modules'         exposed_mod_shapes_u <- traverse (convertMod FromExposedModules) src_provs         -- Handle 'other-modules'@@ -192,8 +217,8 @@         -- Handle 'signatures'         let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s)             convertReq req = do-                req_u <- convertModule (OpenModuleVar req)-                return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u])+              req_u <- convertModule (OpenModuleVar req)+              return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u])         req_shapes_u <- traverse convertReq src_reqs          -- Handle 'mixins'@@ -201,21 +226,27 @@          failIfErrs -- Prevent error cascade         -- Mix-in link everything!  mixLink is the real workhorse.-        shape_u <- mixLink $ exposed_mod_shapes_u-                          ++ other_mod_shapes_u-                          ++ req_shapes_u-                          ++ incl_shapes_u+        shape_u <-+          mixLink $+            exposed_mod_shapes_u+              ++ other_mod_shapes_u+              ++ req_shapes_u+              ++ incl_shapes_u          -- src_reqs_u <- traverse convertReq src_reqs         -- Read out all the final results by converting back         -- into a pure representation.         let convertIncludeU (ComponentInclude dep_aid rns i) = do-                uid <- convertUnitIdU (ann_id dep_aid)-                return (ComponentInclude {-                            ci_ann_id = dep_aid { ann_id = uid },-                            ci_renaming = rns,-                            ci_implicit = i-                        })+              let component_name = pretty $ ann_cname dep_aid+              uid <- convertUnitIdU (ann_id dep_aid) component_name+              return+                ( ComponentInclude+                    { ci_ann_id = dep_aid{ann_id = uid}+                    , ci_renaming = rns+                    , ci_implicit = i+                    }+                )+         shape <- convertModuleScopeU shape_u         let (includes_u, sig_includes_u) = partitionEithers all_includes_u         incls <- traverse convertIncludeU includes_u@@ -223,23 +254,26 @@         return (shape, incls, sig_incls)      let isNotLib (CLib _) = False-        isNotLib _        = True+        isNotLib _ = True     when (not (Set.null reqs) && isNotLib component) $-        dieProgress $-            hang (text "Non-library component has unfilled requirements:")-                4 (vcat [pretty req | req <- Set.toList reqs])+      dieProgress $+        hang+          (text "Non-library component has unfilled requirements:")+          4+          (vcat [pretty req | req <- Set.toList reqs])      -- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg     -- won't allow it (since someone could directly synthesize     -- an 'InstalledPackageInfo' that violates abstraction.)     -- Though, maybe it should be relaxed?     let src_hidden_set = Set.fromList src_hidden-        linked_shape = linked_shape0 {-            modScopeProvides =+        linked_shape =+          linked_shape0+            { modScopeProvides =                 -- Would rather use withoutKeys but need BC                 Map.filterWithKey-                    (\k _ -> not (k `Set.member` src_hidden_set))-                    (modScopeProvides linked_shape0)+                  (\k _ -> not (k `Set.member` src_hidden_set))+                  (modScopeProvides linked_shape0)             }      -- OK, compute the reexports@@ -248,65 +282,102 @@     -- once.     let hdl :: [Either Doc a] -> LogProgress [a]         hdl es =-            case partitionEithers es of-                ([], rs) -> return rs-                (ls, _) ->-                    dieProgress $-                     hang (text "Problem with module re-exports:") 2-                        (vcat [hang (text "-") 2 l | l <- ls])+          case partitionEithers es of+            ([], rs) -> return rs+            (ls, _) ->+              dieProgress $+                hang+                  (text "Problem with module re-exports:")+                  2+                  (vcat [hang (text "-") 2 l | l <- ls])     reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do       case Map.lookup from (modScopeProvides linked_shape) of-        Just cands@(x0:xs0) -> do+        Just cands@(x0 : xs0) -> do           -- Make sure there is at least one candidate           (x, xs) <-             case mb_pn of               Just pn ->-                let matches_pn (FromMixins pn' _ _)     = pn == pn'+                let matches_pn (FromMixins pn' _ _) = pn == pn'                     matches_pn (FromBuildDepends pn' _) = pn == pn'                     matches_pn (FromExposedModules _) = pn == packageName this_pid-                    matches_pn (FromOtherModules _)   = pn == packageName this_pid-                    matches_pn (FromSignatures _)     = pn == packageName this_pid-                in case filter (matches_pn . getSource) cands of-                    (x1:xs1) -> return (x1, xs1)-                    _ -> Left (brokenReexportMsg reex)+                    matches_pn (FromOtherModules _) = pn == packageName this_pid+                    matches_pn (FromSignatures _) = pn == packageName this_pid+                 in case filter (matches_pn . getSource) cands of+                      (x1 : xs1) -> return (x1, xs1)+                      _ -> Left (brokenReexportMsg reex)               Nothing -> return (x0, xs0)           -- Test that all the candidates are consistent           case filter (\x' -> unWithSource x /= unWithSource x') xs of             [] -> return ()             _ -> Left $ ambiguousReexportMsg reex x xs-          return (to, unWithSource x)+          return (to, Just (unWithSource x))         _ ->-          Left (brokenReexportMsg reex)+          -- Can't resolve it right now.. carry on with the assumption it will be resolved+          -- dynamically later by an in-memory package which hasn't been installed yet.+          if anyPromised+            then return (to, Nothing)+            else -- But if nothing is promised, eagerly report an error, as we already know everything.+              Left (brokenReexportMsg reex)      -- TODO: maybe check this earlier; it's syntactically obvious.     let build_reexports m (k, v)-            | Map.member k m =-                dieProgress $ hsep-                    [ text "Module name ", pretty k, text " is exported multiple times." ]-            | otherwise = return (Map.insert k v m)-    provs <- foldM build_reexports Map.empty $-                -- TODO: doublecheck we have checked for-                -- src_provs duplicates already!-                [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++-                reexports_list+          | Map.member k m =+              dieProgress $+                hsep+                  [text "Module name ", pretty k, text " is exported multiple times."]+          | otherwise = return (Map.insert k v m)+    provs <-+      foldM build_reexports Map.empty $+        -- TODO: doublecheck we have checked for+        -- src_provs duplicates already!+        -- These are normal module exports.+        [(mod_name, (OpenModule this_uid mod_name)) | mod_name <- src_provs]+          +++          -- These are reexports, which we managed to resolve to something in an external package.+          [(mn_new, om) | (mn_new, Just om) <- reexports_list]+          +++          -- These ones.. we didn't resolve but also we might not have to+          -- resolve them because they could come from a promised unit,+          -- which we don't know anything about yet. GHC will resolve+          -- these itself when it is dealing with the multi-session.+          -- These ones will not be built, registered and put+          -- into a package database, we only need them to make it as far+          -- as generating GHC options where the info will be used to+          -- pass the reexported-module option to GHC. +          -- We also know that in the case there are promised units that+          -- we will not be doing anything to do with backpack like+          -- unification etc..+          [ ( mod_name+            , OpenModule+                ( DefiniteUnitId+                    ( unsafeMkDefUnitId+                        (mkUnitId "fake")+                    )+                )+                mod_name+            )+          | (mod_name, Nothing) <- reexports_list+          ]+     let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape))      -- See Note Note [Signature package special case]     let (linked_includes, linked_sig_includes)-            | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, [])-            | otherwise     = (linked_includes0, linked_sig_includes0)+          | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, [])+          | otherwise = (linked_includes0, linked_sig_includes0) -    return $ LinkedComponent {-                lc_ann_id = aid,-                lc_component = component,-                lc_public = is_public,-                -- These must be executables-                lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps,-                lc_shape = final_linked_shape,-                lc_includes = linked_includes,-                lc_sig_includes = linked_sig_includes-           }+    return $+      LinkedComponent+        { lc_ann_id = aid+        , lc_component = component+        , lc_public = is_public+        , -- These must be executables+          lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps+        , lc_shape = final_linked_shape+        , lc_includes = linked_includes+        , lc_sig_includes = linked_sig_includes+        }  -- Note [Signature package special case] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -334,63 +405,82 @@ -- Handle mix-in linking for components.  In the absence of Backpack, -- every ComponentId gets converted into a UnitId by way of SimpleUnitId. toLinkedComponents-    :: Verbosity-    -> FullDb-    -> PackageId-    -> LinkedComponentMap-    -> [ConfiguredComponent]-    -> LogProgress [LinkedComponent]-toLinkedComponents verbosity db this_pid lc_map0 comps-   = fmap snd (mapAccumM go lc_map0 comps)- where-  go :: Map ComponentId (OpenUnitId, ModuleShape)-     -> ConfiguredComponent-     -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent)-  go lc_map cc = do-    lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $-            toLinkedComponent verbosity db this_pid lc_map cc-    return (extendLinkedComponentMap lc lc_map, lc)+  :: Verbosity+  -> Bool+  -- ^ Whether there are any "promised" package dependencies which we won't+  -- find already installed.+  -> FullDb+  -> PackageId+  -> LinkedComponentMap+  -> [ConfiguredComponent]+  -> LogProgress [LinkedComponent]+toLinkedComponents verbosity anyPromised db this_pid lc_map0 comps =+  fmap snd (mapAccumM go lc_map0 comps)+  where+    go+      :: Map ComponentId (OpenUnitId, ModuleShape)+      -> ConfiguredComponent+      -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent)+    go lc_map cc = do+      lc <-+        addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $+          toLinkedComponent verbosity anyPromised db this_pid lc_map cc+      return (extendLinkedComponentMap lc lc_map, lc)  type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape) -extendLinkedComponentMap :: LinkedComponent-                         -> LinkedComponentMap-                         -> LinkedComponentMap+extendLinkedComponentMap+  :: LinkedComponent+  -> LinkedComponentMap+  -> LinkedComponentMap extendLinkedComponentMap lc m =-    Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m+  Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m  brokenReexportMsg :: ModuleReexport -> Doc brokenReexportMsg (ModuleReexport (Just pn) from _to) =-  vcat [ text "The package" <+> quotes (pretty pn)-       , text "does not export a module" <+> quotes (pretty from) ]+  vcat+    [ text "The package" <+> quotes (pretty pn)+    , text "does not export a module" <+> quotes (pretty from)+    ] brokenReexportMsg (ModuleReexport Nothing from _to) =-  vcat [ text "The module" <+> quotes (pretty from)-       , text "is not exported by any suitable package."-       , text "It occurs in neither the 'exposed-modules' of this package,"-       , text "nor any of its 'build-depends' dependencies." ]+  vcat+    [ text "The module" <+> quotes (pretty from)+    , text "is not exported by any suitable package."+    , text "It occurs in neither the 'exposed-modules' of this package,"+    , text "nor any of its 'build-depends' dependencies."+    ]  ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc ambiguousReexportMsg (ModuleReexport mb_pn from _to) y1 ys =-  vcat [ text "Ambiguous reexport" <+> quotes (pretty from)-       , hang (text "It could refer to either:") 2-            (vcat (msg : msgs))-       , help_msg mb_pn ]+  vcat+    [ text "Ambiguous reexport" <+> quotes (pretty from)+    , hang+        (text "It could refer to either:")+        2+        (vcat (msg : msgs))+    , help_msg mb_pn+    ]   where-    msg  = text "  " <+> displayModuleWithSource y1+    msg = text "  " <+> displayModuleWithSource y1     msgs = [text "or" <+> displayModuleWithSource y | y <- ys]     help_msg Nothing =       -- TODO: This advice doesn't help if the ambiguous exports       -- come from a package named the same thing-      vcat [ text "The ambiguity can be resolved by qualifying the"-           , text "re-export with a package name."-           , text "The syntax is 'packagename:ModuleName [as NewName]'." ]+      vcat+        [ text "The ambiguity can be resolved by qualifying the"+        , text "re-export with a package name."+        , text "The syntax is 'packagename:ModuleName [as NewName]'."+        ]     -- Qualifying won't help that much.     help_msg (Just _) =-      vcat [ text "The ambiguity can be resolved by using the"-           , text "mixins field to rename one of the module"-           , text "names differently." ]-    displayModuleWithSource y-      = vcat [ quotes (pretty (unWithSource y))-             , text "brought into scope by" <+>-                dispModuleSource (getSource y)-             ]+      vcat+        [ text "The ambiguity can be resolved by using the"+        , text "mixins field to rename one of the module"+        , text "names differently."+        ]+    displayModuleWithSource y =+      vcat+        [ quotes (pretty (unWithSource y))+        , text "brought into scope by"+            <+> dispModuleSource (getSource y)+        ]
src/Distribution/Backpack/MixLink.hs view
@@ -1,26 +1,27 @@ {-# LANGUAGE NondecreasingIndentation #-}+ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.MixLink (-    mixLink,-) where+module Distribution.Backpack.MixLink+  ( mixLink+  ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod)+import Prelude ()  import Distribution.Backpack-import Distribution.Backpack.UnifyM import Distribution.Backpack.FullUnitId import Distribution.Backpack.ModuleScope+import Distribution.Backpack.UnifyM -import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.ModuleName import Distribution.Pretty import Distribution.Types.ComponentId+import qualified Distribution.Utils.UnionFind as UnionFind -import Text.PrettyPrint import Control.Monad-import qualified Data.Map as Map import qualified Data.Foldable as F+import qualified Data.Map as Map+import Text.PrettyPrint  ----------------------------------------------------------------------- -- Linking@@ -28,78 +29,98 @@ -- | Given to scopes of provisions and requirements, link them together. mixLink :: [ModuleScopeU s] -> UnifyM s (ModuleScopeU s) mixLink scopes = do-    let provs = Map.unionsWith (++) (map fst scopes)-        -- Invariant: any identically named holes refer to same mutable cell-        reqs  = Map.unionsWith (++) (map snd scopes)-        filled = Map.intersectionWithKey linkProvision provs reqs-    F.sequenceA_ filled-    let remaining = Map.difference reqs filled-    return (provs, remaining)+  let provs = Map.unionsWith (++) (map fst scopes)+      -- Invariant: any identically named holes refer to same mutable cell+      reqs = Map.unionsWith (++) (map snd scopes)+      filled = Map.intersectionWithKey linkProvision provs reqs+  F.sequenceA_ filled+  let remaining = Map.difference reqs filled+  return (provs, remaining)  -- | Link a list of possibly provided modules to a single -- requirement.  This applies a side-condition that all -- of the provided modules at the same name are *actually* -- the same module.-linkProvision :: ModuleName-              -> [ModuleWithSourceU s] -- provs-              -> [ModuleWithSourceU s] -- reqs-              -> UnifyM s [ModuleWithSourceU s]-linkProvision mod_name ret@(prov:provs) (req:reqs) = do-    -- TODO: coalesce all the non-unifying modules together-    forM_ provs $ \prov' -> do-        -- Careful: read it out BEFORE unifying, because the-        -- unification algorithm preemptively unifies modules-        mod  <- convertModuleU (unWithSource prov)-        mod' <- convertModuleU (unWithSource prov')-        r <- unify prov prov'-        case r of-            Just () -> return ()-            Nothing -> do-                addErr $-                  text "Ambiguous module" <+> quotes (pretty mod_name) $$-                  text "It could refer to" <+>-                    ( text "  " <+> (quotes (pretty mod)  $$ in_scope_by (getSource prov)) $$-                      text "or" <+> (quotes (pretty mod') $$ in_scope_by (getSource prov')) ) $$-                  link_doc+linkProvision+  :: ModuleName+  -> [ModuleWithSourceU s] -- provs+  -> [ModuleWithSourceU s] -- reqs+  -> UnifyM s [ModuleWithSourceU s]+linkProvision mod_name ret@(prov : provs) (req : reqs) = do+  -- TODO: coalesce all the non-unifying modules together+  forM_ provs $ \prov' -> do+    -- Careful: read it out BEFORE unifying, because the+    -- unification algorithm preemptively unifies modules     mod <- convertModuleU (unWithSource prov)-    req_mod <- convertModuleU (unWithSource req)-    self_cid <- fmap unify_self_cid getUnifEnv-    case mod of-      OpenModule (IndefFullUnitId cid _) _-        | cid == self_cid -> addErr $-            text "Cannot instantiate requirement" <+> quotes (pretty mod_name) <+>-                in_scope_by (getSource req) $$-            text "with locally defined module" <+> in_scope_by (getSource prov) $$-            text "as this would create a cyclic dependency, which GHC does not support." $$-            text "Try moving this module to a separate library, e.g.," $$-            text "create a new stanza: library 'sublib'."-      _ -> return ()-    r <- unify prov req+    mod' <- convertModuleU (unWithSource prov')+    r <- unify prov prov'     case r of-        Just () -> return ()-        Nothing -> do-            -- TODO: Record and report WHERE the bad constraint came from-            addErr $ text "Could not instantiate requirement" <+> quotes (pretty mod_name) $$-                     nest 4 (text "Expected:" <+> pretty mod $$-                             text "Actual:  " <+> pretty req_mod) $$-                     parens (text "This can occur if an exposed module of" <+>-                             text "a libraries shares a name with another module.") $$-                     link_doc-    return ret+      Just () -> return ()+      Nothing -> do+        addErr $+          text "Ambiguous module"+            <+> quotes (pretty mod_name)+            $$ text "It could refer to"+            <+> ( text "  "+                    <+> (quotes (pretty mod) $$ in_scope_by (getSource prov))+                    $$ text "or"+                    <+> (quotes (pretty mod') $$ in_scope_by (getSource prov'))+                )+            $$ link_doc+  mod <- convertModuleU (unWithSource prov)+  req_mod <- convertModuleU (unWithSource req)+  self_cid <- fmap unify_self_cid getUnifEnv+  case mod of+    OpenModule (IndefFullUnitId cid _) _+      | cid == self_cid ->+          addErr $+            text "Cannot instantiate requirement"+              <+> quotes (pretty mod_name)+              <+> in_scope_by (getSource req)+              $$ text "with locally defined module"+              <+> in_scope_by (getSource prov)+              $$ text "as this would create a cyclic dependency, which GHC does not support."+              $$ text "Try moving this module to a separate library, e.g.,"+              $$ text "create a new stanza: library 'sublib'."+    _ -> return ()+  r <- unify prov req+  case r of+    Just () -> return ()+    Nothing -> do+      -- TODO: Record and report WHERE the bad constraint came from+      addErr $+        text "Could not instantiate requirement"+          <+> quotes (pretty mod_name)+          $$ nest+            4+            ( text "Expected:"+                <+> pretty mod+                $$ text "Actual:  "+                <+> pretty req_mod+            )+          $$ parens+            ( text "This can occur if an exposed module of"+                <+> text "a libraries shares a name with another module."+            )+          $$ link_doc+  return ret   where-    unify s1 s2 = tryM $ addErrContext short_link_doc-                       $ unifyModule (unWithSource s1) (unWithSource s2)+    unify s1 s2 =+      tryM $+        addErrContext short_link_doc $+          unifyModule (unWithSource s1) (unWithSource s2)     in_scope_by s = text "brought into scope by" <+> dispModuleSource s     short_link_doc = text "While filling requirement" <+> quotes (pretty mod_name)     link_doc = text "While filling requirements of" <+> reqs_doc     reqs_doc       | null reqs = dispModuleSource (getSource req)-      | otherwise =  (       text "   " <+> dispModuleSource (getSource req)  $$-                      vcat [ text "and" <+> dispModuleSource (getSource r) | r <- reqs])+      | otherwise =+          ( text "   "+              <+> dispModuleSource (getSource req)+              $$ vcat [text "and" <+> dispModuleSource (getSource r) | r <- reqs]+          ) linkProvision _ _ _ = error "linkProvision" -- ----------------------------------------------------------------------- -- The unification algorithm @@ -108,78 +129,93 @@  unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s () unifyUnitId uid1_u uid2_u-    | uid1_u == uid2_u = return ()-    | otherwise = do-        xuid1 <- liftST $ UnionFind.find uid1_u-        xuid2 <- liftST $ UnionFind.find uid2_u-        case (xuid1, xuid2) of-            (UnitIdThunkU u1, UnitIdThunkU u2)-                | u1 == u2  -> return ()-                | otherwise ->-                    failWith $ hang (text "Couldn't match unit IDs:") 4-                               (text "   " <+> pretty u1 $$-                                text "and" <+> pretty u2)-            (UnitIdThunkU uid1, UnitIdU _ cid2 insts2)-                -> unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u-            (UnitIdU _ cid1 insts1, UnitIdThunkU uid2)-                -> unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u-            (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2)-                -> unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u+  | uid1_u == uid2_u = return ()+  | otherwise = do+      xuid1 <- liftST $ UnionFind.find uid1_u+      xuid2 <- liftST $ UnionFind.find uid2_u+      case (xuid1, xuid2) of+        (UnitIdThunkU u1, UnitIdThunkU u2)+          | u1 == u2 -> return ()+          | otherwise ->+              failWith $+                hang+                  (text "Couldn't match unit IDs:")+                  4+                  ( text "   "+                      <+> pretty u1+                      $$ text "and"+                      <+> pretty u2+                  )+        (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) ->+          unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u+        (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) ->+          unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u+        (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2) ->+          unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u -unifyThunkWith :: ComponentId-               -> Map ModuleName (ModuleU s)-               -> UnitIdU s-               -> DefUnitId-               -> UnitIdU s-               -> UnifyM s ()+unifyThunkWith+  :: ComponentId+  -> Map ModuleName (ModuleU s)+  -> UnitIdU s+  -> DefUnitId+  -> UnitIdU s+  -> UnifyM s () unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do-    db <- fmap unify_db getUnifEnv-    let FullUnitId cid2 insts2' = expandUnitId db uid2-    insts2 <- convertModuleSubst insts2'-    unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u+  db <- fmap unify_db getUnifEnv+  let FullUnitId cid2 insts2' = expandUnitId db uid2+  insts2 <- convertModuleSubst insts2'+  unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u -unifyInner :: ComponentId-           -> Map ModuleName (ModuleU s)-           -> UnitIdU s-           -> ComponentId-           -> Map ModuleName (ModuleU s)-           -> UnitIdU s-           -> UnifyM s ()+unifyInner+  :: ComponentId+  -> Map ModuleName (ModuleU s)+  -> UnitIdU s+  -> ComponentId+  -> Map ModuleName (ModuleU s)+  -> UnitIdU s+  -> UnifyM s () unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u = do-    when (cid1 /= cid2) $-        -- TODO: if we had a package identifier, could be an-        -- easier to understand error message.-        failWith $-            hang (text "Couldn't match component IDs:") 4-                 (text "   " <+> pretty cid1 $$-                  text "and" <+> pretty cid2)-    -- The KEY STEP which makes this a Huet-style unification-    -- algorithm.  (Also a payoff of using union-find.)-    -- We can build infinite unit IDs this way, which is necessary-    -- for support mutual recursion. NB: union keeps the SECOND-    -- descriptor, so we always arrange for a UnitIdThunkU to live-    -- there.-    liftST $ UnionFind.union uid1_u uid2_u-    F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2+  when (cid1 /= cid2) $+    -- TODO: if we had a package identifier, could be an+    -- easier to understand error message.+    failWith $+      hang+        (text "Couldn't match component IDs:")+        4+        ( text "   "+            <+> pretty cid1+            $$ text "and"+            <+> pretty cid2+        )+  -- The KEY STEP which makes this a Huet-style unification+  -- algorithm.  (Also a payoff of using union-find.)+  -- We can build infinite unit IDs this way, which is necessary+  -- for support mutual recursion. NB: union keeps the SECOND+  -- descriptor, so we always arrange for a UnitIdThunkU to live+  -- there.+  liftST $ UnionFind.union uid1_u uid2_u+  F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2  -- | Imperatively unify two modules. unifyModule :: ModuleU s -> ModuleU s -> UnifyM s () unifyModule mod1_u mod2_u-    | mod1_u == mod2_u = return ()-    | otherwise = do-        mod1 <- liftST $ UnionFind.find mod1_u-        mod2 <- liftST $ UnionFind.find mod2_u-        case (mod1, mod2) of-            (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u-            (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u-            (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do-                when (mod_name1 /= mod_name2) $-                    failWith $-                        hang (text "Cannot match module names") 4 $-                            text "   " <+> pretty mod_name1 $$-                            text "and" <+> pretty mod_name2-                -- NB: this is not actually necessary (because we'll-                -- detect loops eventually in 'unifyUnitId'), but it-                -- seems harmless enough-                liftST $ UnionFind.union mod1_u mod2_u-                unifyUnitId uid1 uid2+  | mod1_u == mod2_u = return ()+  | otherwise = do+      mod1 <- liftST $ UnionFind.find mod1_u+      mod2 <- liftST $ UnionFind.find mod2_u+      case (mod1, mod2) of+        (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u+        (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u+        (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do+          when (mod_name1 /= mod_name2) $+            failWith $+              hang (text "Cannot match module names") 4 $+                text "   "+                  <+> pretty mod_name1+                  $$ text "and"+                  <+> pretty mod_name2+          -- NB: this is not actually necessary (because we'll+          -- detect loops eventually in 'unifyUnitId'), but it+          -- seems harmless enough+          liftST $ UnionFind.union mod1_u mod2_u+          unifyUnitId uid1 uid2
src/Distribution/Backpack/ModSubst.hs view
@@ -5,13 +5,12 @@ -- applied to them. -- -- See also <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>--module Distribution.Backpack.ModSubst (-    ModSubst(..),-) where+module Distribution.Backpack.ModSubst+  ( ModSubst (..)+  ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod)+import Prelude ()  import Distribution.Backpack import Distribution.ModuleName@@ -21,32 +20,33 @@  -- | Applying module substitutions to semantic objects. class ModSubst a where-    -- In notation, substitution is postfix, which implies-    -- putting it on the right hand side, but for partial-    -- application it's more convenient to have it on the left-    -- hand side.-    modSubst :: OpenModuleSubst -> a -> a+  -- In notation, substitution is postfix, which implies+  -- putting it on the right hand side, but for partial+  -- application it's more convenient to have it on the left+  -- hand side.+  modSubst :: OpenModuleSubst -> a -> a  instance ModSubst OpenModule where-    modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name-    modSubst subst mod@(OpenModuleVar mod_name)-        | Just mod' <- Map.lookup mod_name subst = mod'-        | otherwise = mod+  modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name+  modSubst subst mod@(OpenModuleVar mod_name)+    | Just mod' <- Map.lookup mod_name subst = mod'+    | otherwise = mod  instance ModSubst OpenUnitId where-    modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts)-    modSubst _subst uid = uid+  modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts)+  modSubst _subst uid = uid  instance ModSubst (Set ModuleName) where-    modSubst subst reqs-        = Set.union (Set.difference reqs (Map.keysSet subst))-                    (openModuleSubstFreeHoles subst)+  modSubst subst reqs =+    Set.union+      (Set.difference reqs (Map.keysSet subst))+      (openModuleSubstFreeHoles subst)  -- Substitutions are functorial.  NB: this means that -- there is an @instance 'ModSubst' 'ModuleSubst'@! instance ModSubst a => ModSubst (Map k a) where-    modSubst subst = fmap (modSubst subst)+  modSubst subst = fmap (modSubst subst) instance ModSubst a => ModSubst [a] where-    modSubst subst = fmap (modSubst subst)+  modSubst subst = fmap (modSubst subst) instance ModSubst a => ModSubst (k, a) where-    modSubst subst (x,y) = (x, modSubst subst y)+  modSubst subst (x, y) = (x, modSubst subst y)
src/Distribution/Backpack/ModuleScope.hs view
@@ -1,30 +1,29 @@-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DeriveFoldable #-}+ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.ModuleScope (-    -- * Module scopes-    ModuleScope(..),-    ModuleProvides,-    ModuleRequires,-    ModuleSource(..),-    dispModuleSource,-    WithSource(..),-    unWithSource,-    getSource,-    ModuleWithSource,-    emptyModuleScope,-) where+module Distribution.Backpack.ModuleScope+  ( -- * Module scopes+    ModuleScope (..)+  , ModuleProvides+  , ModuleRequires+  , ModuleSource (..)+  , dispModuleSource+  , WithSource (..)+  , unWithSource+  , getSource+  , ModuleWithSource+  , emptyModuleScope+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import Distribution.ModuleName-import Distribution.Types.IncludeRenaming-import Distribution.Types.PackageName+import Distribution.Pretty import Distribution.Types.ComponentName+import Distribution.Types.IncludeRenaming import Distribution.Types.LibraryName-import Distribution.Pretty+import Distribution.Types.PackageName  import Distribution.Backpack import Distribution.Backpack.ModSubst@@ -32,7 +31,6 @@ import qualified Data.Map as Map import Text.PrettyPrint - ----------------------------------------------------------------------- -- Module scopes @@ -60,17 +58,16 @@ -- Alternate strategy: go ahead and unify, and then if it is revealed -- that some requirements got filled "out-of-thin-air", error. - -- | A 'ModuleScope' describes the modules and requirements that -- are in-scope as we are processing a Cabal package.  Unlike -- a 'ModuleShape', there may be multiple modules in scope at -- the same 'ModuleName'; this is only an error if we attempt -- to use those modules to fill a requirement.  A 'ModuleScope' -- can influence the 'ModuleShape' via a reexport.-data ModuleScope = ModuleScope {-    modScopeProvides :: ModuleProvides,-    modScopeRequires :: ModuleRequires-    }+data ModuleScope = ModuleScope+  { modScopeProvides :: ModuleProvides+  , modScopeRequires :: ModuleRequires+  }  -- | An empty 'ModuleScope'. emptyModuleScope :: ModuleScope@@ -79,49 +76,53 @@ -- | Every 'Module' in scope at a 'ModuleName' is annotated with -- the 'PackageName' it comes from. type ModuleProvides = Map ModuleName [ModuleWithSource]+ -- | INVARIANT: entries for ModuleName m, have msrc_module is OpenModuleVar m type ModuleRequires = Map ModuleName [ModuleWithSource]+ -- TODO: consider newtping the two types above.  -- | Description of where a module participating in mixin linking came -- from. data ModuleSource-    = FromMixins         PackageName ComponentName IncludeRenaming-    | FromBuildDepends   PackageName ComponentName-    | FromExposedModules ModuleName-    | FromOtherModules   ModuleName-    | FromSignatures     ModuleName+  = FromMixins PackageName ComponentName IncludeRenaming+  | FromBuildDepends PackageName ComponentName+  | FromExposedModules ModuleName+  | FromOtherModules ModuleName+  | FromSignatures ModuleName+ -- We don't have line numbers, but if we did, we'd want to record that -- too  -- TODO: Deduplicate this with Distribution.Backpack.UnifyM.ci_msg dispModuleSource :: ModuleSource -> Doc-dispModuleSource (FromMixins pn cn incls)-  = text "mixins:" <+> dispComponent pn cn <+> pretty incls-dispModuleSource (FromBuildDepends pn cn)-  = text "build-depends:" <+> dispComponent pn cn-dispModuleSource (FromExposedModules m)-  = text "exposed-modules:" <+> pretty m-dispModuleSource (FromOtherModules m)-  = text "other-modules:" <+> pretty m-dispModuleSource (FromSignatures m)-  = text "signatures:" <+> pretty m+dispModuleSource (FromMixins pn cn incls) =+  text "mixins:" <+> dispComponent pn cn <+> pretty incls+dispModuleSource (FromBuildDepends pn cn) =+  text "build-depends:" <+> dispComponent pn cn+dispModuleSource (FromExposedModules m) =+  text "exposed-modules:" <+> pretty m+dispModuleSource (FromOtherModules m) =+  text "other-modules:" <+> pretty m+dispModuleSource (FromSignatures m) =+  text "signatures:" <+> pretty m  -- Dependency dispComponent :: PackageName -> ComponentName -> Doc dispComponent pn cn =-    -- NB: This syntax isn't quite the source syntax, but it-    -- should be clear enough.  To do source syntax, we'd-    -- need to know what the package we're linking is.-    case cn of-        CLibName LMainLibName -> pretty pn-        CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn-        -- Case below shouldn't happen-        _ -> pretty pn <+> parens (pretty cn)+  -- NB: This syntax isn't quite the source syntax, but it+  -- should be clear enough.  To do source syntax, we'd+  -- need to know what the package we're linking is.+  case cn of+    CLibName LMainLibName -> pretty pn+    CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn+    -- Case below shouldn't happen+    _ -> pretty pn <+> parens (pretty cn)  -- | An 'OpenModule', annotated with where it came from in a Cabal file. data WithSource a = WithSource ModuleSource a-    deriving (Functor, Foldable, Traversable)+  deriving (Functor, Foldable, Traversable)+ unWithSource :: WithSource a -> a unWithSource (WithSource _ x) = x getSource :: WithSource a -> ModuleSource@@ -129,4 +130,4 @@ type ModuleWithSource = WithSource OpenModule  instance ModSubst a => ModSubst (WithSource a) where-    modSubst subst (WithSource s m) = WithSource s (modSubst subst m)+  modSubst subst (WithSource s m) = WithSource s (modSubst subst m)
src/Distribution/Backpack/ModuleShape.hs view
@@ -1,21 +1,21 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.ModuleShape (-    -- * Module shapes-    ModuleShape(..),-    emptyModuleShape,-    shapeInstalledPackage,-) where+module Distribution.Backpack.ModuleShape+  ( -- * Module shapes+    ModuleShape (..)+  , emptyModuleShape+  , shapeInstalledPackage+  ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod)+import Prelude () -import Distribution.ModuleName import Distribution.InstalledPackageInfo as IPI+import Distribution.ModuleName -import Distribution.Backpack.ModSubst import Distribution.Backpack+import Distribution.Backpack.ModSubst  import qualified Data.Map as Map import qualified Data.Set as Set@@ -26,18 +26,18 @@ -- | A 'ModuleShape' describes the provisions and requirements of -- a library.  We can extract a 'ModuleShape' from an -- 'InstalledPackageInfo'.-data ModuleShape = ModuleShape {-    modShapeProvides :: OpenModuleSubst,-    modShapeRequires :: Set ModuleName-    }-    deriving (Eq, Show, Generic, Typeable)+data ModuleShape = ModuleShape+  { modShapeProvides :: OpenModuleSubst+  , modShapeRequires :: Set ModuleName+  }+  deriving (Eq, Show, Generic)  instance Binary ModuleShape instance Structured ModuleShape  instance ModSubst ModuleShape where-    modSubst subst (ModuleShape provs reqs)-        = ModuleShape (modSubst subst provs) (modSubst subst reqs)+  modSubst subst (ModuleShape provs reqs) =+    ModuleShape (modSubst subst provs) (modSubst subst reqs)  -- | The default module shape, with no provisions and no requirements. emptyModuleShape :: ModuleShape@@ -78,7 +78,7 @@     uid = installedOpenUnitId ipi     provs = map shapeExposedModule (IPI.exposedModules ipi)     reqs = requiredSignatures ipi-    shapeExposedModule (IPI.ExposedModule mod_name Nothing)-        = (mod_name, OpenModule uid mod_name)-    shapeExposedModule (IPI.ExposedModule mod_name (Just mod))-        = (mod_name, mod)+    shapeExposedModule (IPI.ExposedModule mod_name Nothing) =+      (mod_name, OpenModule uid mod_name)+    shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) =+      (mod_name, mod)
src/Distribution/Backpack/PreExistingComponent.hs view
@@ -1,59 +1,70 @@ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.PreExistingComponent (-    PreExistingComponent(..),-    ipiToPreExistingComponent,-) where+module Distribution.Backpack.PreExistingComponent+  ( PreExistingComponent (..)+  , ConfiguredPromisedComponent (..)+  , ipiToPreExistingComponent+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Backpack.ModuleShape import Distribution.Backpack-import Distribution.Types.ComponentId-import Distribution.Types.MungedPackageId-import Distribution.Types.PackageId-import Distribution.Types.UnitId-import Distribution.Types.ComponentName-import Distribution.Types.PackageName+import Distribution.Backpack.ModuleShape import Distribution.Package+import Distribution.Types.ComponentName+import Distribution.Types.MungedPackageId  import qualified Data.Map as Map-import qualified Distribution.InstalledPackageInfo as Installed import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import qualified Distribution.InstalledPackageInfo as Installed+import Distribution.Types.AnnotatedId +-- | A /promised/ component.+--+-- These components are promised to @configure@ but are not yet built.+--+-- In other words this is 'PreExistingComponent' which doesn't yet exist.+data ConfiguredPromisedComponent = ConfiguredPromisedComponent+  { pr_pkgname :: PackageName+  , pr_cid :: AnnotatedId ComponentId+  }++instance Package ConfiguredPromisedComponent where+  packageId = packageId . pr_cid+ -- | Stripped down version of 'LinkedComponent' for things -- we don't need to know how to build.-data PreExistingComponent-    = PreExistingComponent {-        -- | The actual name of the package. This may DISAGREE with 'pc_pkgid'-        -- for internal dependencies: e.g., an internal component @lib@ may be-        -- munged to @z-pkg-z-lib@, but we still want to use it when we see-        -- @lib@ in @build-depends@-        pc_pkgname :: PackageName,-        -- | The actual name of the component.-        pc_compname :: ComponentName,-        pc_munged_id :: MungedPackageId,-        pc_uid   :: UnitId,-        pc_cid   :: ComponentId,-        pc_open_uid :: OpenUnitId,-        pc_shape :: ModuleShape-    }+data PreExistingComponent = PreExistingComponent+  { pc_pkgname :: PackageName+  -- ^ The actual name of the package. This may DISAGREE with 'pc_pkgid'+  -- for internal dependencies: e.g., an internal component @lib@ may be+  -- munged to @z-pkg-z-lib@, but we still want to use it when we see+  -- @lib@ in @build-depends@+  , pc_compname :: ComponentName+  -- ^ The actual name of the component.+  , pc_munged_id :: MungedPackageId+  , pc_uid :: UnitId+  , pc_cid :: ComponentId+  , pc_open_uid :: OpenUnitId+  , pc_shape :: ModuleShape+  }  -- | Convert an 'InstalledPackageInfo' into a 'PreExistingComponent', -- which was brought into scope under the 'PackageName' (important for -- a package qualified reference.) ipiToPreExistingComponent :: InstalledPackageInfo -> PreExistingComponent ipiToPreExistingComponent ipi =-    PreExistingComponent {-        pc_pkgname = packageName ipi,-        pc_compname = CLibName $ Installed.sourceLibName ipi,-        pc_munged_id = mungedId ipi,-        pc_uid   = Installed.installedUnitId ipi,-        pc_cid   = Installed.installedComponentId ipi,-        pc_open_uid =-            IndefFullUnitId (Installed.installedComponentId ipi)-                            (Map.fromList (Installed.instantiatedWith ipi)),-        pc_shape = shapeInstalledPackage ipi+  PreExistingComponent+    { pc_pkgname = packageName ipi+    , pc_compname = CLibName $ Installed.sourceLibName ipi+    , pc_munged_id = mungedId ipi+    , pc_uid = Installed.installedUnitId ipi+    , pc_cid = Installed.installedComponentId ipi+    , pc_open_uid =+        IndefFullUnitId+          (Installed.installedComponentId ipi)+          (Map.fromList (Installed.instantiatedWith ipi))+    , pc_shape = shapeInstalledPackage ipi     }  instance HasMungedPackageId PreExistingComponent where@@ -61,7 +72,8 @@  instance Package PreExistingComponent where   packageId pec = PackageIdentifier (pc_pkgname pec) v-    where MungedPackageId _ v = pc_munged_id pec+    where+      MungedPackageId _ v = pc_munged_id pec  instance HasUnitId PreExistingComponent where   installedUnitId = pc_uid
src/Distribution/Backpack/PreModuleShape.hs view
@@ -1,38 +1,37 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Backpack.PreModuleShape (-    PreModuleShape(..),-    toPreModuleShape,-    renamePreModuleShape,-    mixLinkPreModuleShape,-) where+module Distribution.Backpack.PreModuleShape+  ( PreModuleShape (..)+  , toPreModuleShape+  , renamePreModuleShape+  , mixLinkPreModuleShape+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import qualified Data.Set as Set import qualified Data.Map as Map+import qualified Data.Set as Set  import Distribution.Backpack.ModuleShape+import Distribution.ModuleName import Distribution.Types.IncludeRenaming import Distribution.Types.ModuleRenaming-import Distribution.ModuleName -data PreModuleShape = PreModuleShape {-        preModShapeProvides :: Set ModuleName,-        preModShapeRequires :: Set ModuleName-    }-    deriving (Eq, Show, Generic)+data PreModuleShape = PreModuleShape+  { preModShapeProvides :: Set ModuleName+  , preModShapeRequires :: Set ModuleName+  }+  deriving (Eq, Show, Generic)  toPreModuleShape :: ModuleShape -> PreModuleShape toPreModuleShape (ModuleShape provs reqs) = PreModuleShape (Map.keysSet provs) reqs  renamePreModuleShape :: PreModuleShape -> IncludeRenaming -> PreModuleShape renamePreModuleShape (PreModuleShape provs reqs) (IncludeRenaming prov_rn req_rn) =-    PreModuleShape-        (Set.fromList (mapMaybe prov_fn (Set.toList provs)))-        (Set.map req_fn reqs)+  PreModuleShape+    (Set.fromList (mapMaybe prov_fn (Set.toList provs)))+    (Set.map req_fn reqs)   where     prov_fn = interpModuleRenaming prov_rn     req_fn k = fromMaybe k (interpModuleRenaming req_rn k)@@ -41,4 +40,4 @@ mixLinkPreModuleShape shapes = PreModuleShape provs (Set.difference reqs provs)   where     provs = Set.unions (map preModShapeProvides shapes)-    reqs  = Set.unions (map preModShapeRequires shapes)+    reqs = Set.unions (map preModShapeRequires shapes)
src/Distribution/Backpack/ReadyComponent.hs view
@@ -1,186 +1,199 @@-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeFamilies #-}+ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.ReadyComponent (-    ReadyComponent(..),-    InstantiatedComponent(..),-    IndefiniteComponent(..),-    rc_depends,-    rc_uid,-    rc_pkgid,-    dispReadyComponent,-    toReadyComponents,-) where+module Distribution.Backpack.ReadyComponent+  ( ReadyComponent (..)+  , InstantiatedComponent (..)+  , IndefiniteComponent (..)+  , rc_depends+  , rc_uid+  , rc_pkgid+  , dispReadyComponent+  , toReadyComponents+  ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>))+import Prelude ()  import Distribution.Backpack import Distribution.Backpack.LinkedComponent import Distribution.Backpack.ModuleShape +import Distribution.Compat.Graph (IsNode (..)) import Distribution.Types.AnnotatedId-import Distribution.Types.ModuleRenaming import Distribution.Types.Component-import Distribution.Types.ComponentInclude import Distribution.Types.ComponentId+import Distribution.Types.ComponentInclude import Distribution.Types.ComponentName-import Distribution.Types.PackageId-import Distribution.Types.PackageName.Magic-import Distribution.Types.UnitId-import Distribution.Compat.Graph (IsNode(..))+import Distribution.Types.Library+import Distribution.Types.LibraryName import Distribution.Types.Module+import Distribution.Types.ModuleRenaming import Distribution.Types.MungedPackageId import Distribution.Types.MungedPackageName-import Distribution.Types.Library-import Distribution.Types.LibraryName+import Distribution.Types.PackageId+import Distribution.Types.PackageName.Magic+import Distribution.Types.UnitId  import Distribution.ModuleName import Distribution.Package import Distribution.Simple.Utils  import Control.Monad-import Text.PrettyPrint import qualified Data.Map as Map import qualified Data.Set as Set+import Text.PrettyPrint -import Distribution.Version import Distribution.Pretty+import Distribution.Version  -- | A 'ReadyComponent' is one that we can actually generate build -- products for.  We have a ready component for the typecheck-only -- products of every indefinite package, as well as a ready component -- for every way these packages can be fully instantiated.----data ReadyComponent-    = ReadyComponent {-        rc_ann_id       :: AnnotatedId UnitId,-        -- | The 'OpenUnitId' for this package.  At the moment, this-        -- is used in only one case, which is to determine if an-        -- export is of a module from this library (indefinite-        -- libraries record these exports as 'OpenModule');-        -- 'rc_open_uid' can be conveniently used to test for-        -- equality, whereas 'UnitId' cannot always be used in this-        -- case.-        rc_open_uid     :: OpenUnitId,-        -- | Corresponds to 'lc_cid'.  Invariant: if 'rc_open_uid'-        -- records a 'ComponentId', it coincides with this one.-        rc_cid          :: ComponentId,-        -- | Corresponds to 'lc_component'.-        rc_component    :: Component,-        -- | Corresponds to 'lc_exe_deps'.-        -- Build-tools don't participate in mix-in linking.-        -- (but what if they could?)-        rc_exe_deps     :: [AnnotatedId UnitId],-        -- | Corresponds to 'lc_public'.-        rc_public       :: Bool,-        -- | Extra metadata depending on whether or not this is an-        -- indefinite library (typechecked only) or an instantiated-        -- component (can be compiled).-        rc_i            :: Either IndefiniteComponent InstantiatedComponent-    }+data ReadyComponent = ReadyComponent+  { rc_ann_id :: AnnotatedId UnitId+  , rc_open_uid :: OpenUnitId+  -- ^ The 'OpenUnitId' for this package.  At the moment, this+  -- is used in only one case, which is to determine if an+  -- export is of a module from this library (indefinite+  -- libraries record these exports as 'OpenModule');+  -- 'rc_open_uid' can be conveniently used to test for+  -- equality, whereas 'UnitId' cannot always be used in this+  -- case.+  , rc_cid :: ComponentId+  -- ^ Corresponds to 'lc_cid'.  Invariant: if 'rc_open_uid'+  -- records a 'ComponentId', it coincides with this one.+  , rc_component :: Component+  -- ^ Corresponds to 'lc_component'.+  , rc_exe_deps :: [AnnotatedId UnitId]+  -- ^ Corresponds to 'lc_exe_deps'.+  -- Build-tools don't participate in mix-in linking.+  -- (but what if they could?)+  , rc_public :: Bool+  -- ^ Corresponds to 'lc_public'.+  , rc_i :: Either IndefiniteComponent InstantiatedComponent+  -- ^ Extra metadata depending on whether or not this is an+  -- indefinite library (typechecked only) or an instantiated+  -- component (can be compiled).+  }  -- | The final, string 'UnitId' that will uniquely identify -- the compilation products of this component.-rc_uid          :: ReadyComponent -> UnitId+rc_uid :: ReadyComponent -> UnitId rc_uid = ann_id . rc_ann_id  -- | Corresponds to 'lc_pkgid'.-rc_pkgid        :: ReadyComponent -> PackageId+rc_pkgid :: ReadyComponent -> PackageId rc_pkgid = ann_pid . rc_ann_id  -- | An 'InstantiatedComponent' is a library which is fully instantiated -- (or, possibly, has no requirements at all.)-data InstantiatedComponent-    = InstantiatedComponent {-        -- | How this library was instantiated.-        instc_insts    :: [(ModuleName, Module)],-        -- | Dependencies induced by 'instc_insts'.  These are recorded-        -- here because there isn't a convenient way otherwise to get-        -- the 'PackageId' we need to fill 'componentPackageDeps' as needed.-        instc_insts_deps :: [(UnitId, MungedPackageId)],-        -- | The modules exported/reexported by this library.-        instc_provides :: Map ModuleName Module,-        -- | The dependencies which need to be passed to the compiler-        -- to bring modules into scope.  These always refer to installed-        -- fully instantiated libraries.-        instc_includes :: [ComponentInclude DefUnitId ModuleRenaming]-    }+data InstantiatedComponent = InstantiatedComponent+  { instc_insts :: [(ModuleName, Module)]+  -- ^ How this library was instantiated.+  , instc_insts_deps :: [(UnitId, MungedPackageId)]+  -- ^ Dependencies induced by 'instc_insts'.  These are recorded+  -- here because there isn't a convenient way otherwise to get+  -- the 'PackageId' we need to fill 'componentPackageDeps' as needed.+  , instc_provides :: Map ModuleName Module+  -- ^ The modules exported/reexported by this library.+  , instc_includes :: [ComponentInclude DefUnitId ModuleRenaming]+  -- ^ The dependencies which need to be passed to the compiler+  -- to bring modules into scope.  These always refer to installed+  -- fully instantiated libraries.+  }  -- | An 'IndefiniteComponent' is a library with requirements -- which we will typecheck only.-data IndefiniteComponent-    = IndefiniteComponent {-        -- | The requirements of the library.-        indefc_requires :: [ModuleName],-        -- | The modules exported/reexported by this library.-        indefc_provides :: Map ModuleName OpenModule,-        -- | The dependencies which need to be passed to the compiler-        -- to bring modules into scope.  These are 'OpenUnitId' because-        -- these may refer to partially instantiated libraries.-        indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]-    }+data IndefiniteComponent = IndefiniteComponent+  { indefc_requires :: [ModuleName]+  -- ^ The requirements of the library.+  , indefc_provides :: Map ModuleName OpenModule+  -- ^ The modules exported/reexported by this library.+  , indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]+  -- ^ The dependencies which need to be passed to the compiler+  -- to bring modules into scope.  These are 'OpenUnitId' because+  -- these may refer to partially instantiated libraries.+  }  -- | Compute the dependencies of a 'ReadyComponent' that should -- be recorded in the @depends@ field of 'InstalledPackageInfo'. rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)] rc_depends rc = ordNub $-    case rc_i rc of-        Left indefc ->-            map (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci))-                (indefc_includes indefc)-        Right instc ->-            map (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci))-                (instc_includes instc)-              ++ instc_insts_deps instc+  case rc_i rc of+    Left indefc ->+      map+        (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci))+        (indefc_includes indefc)+    Right instc ->+      map+        (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci))+        (instc_includes instc)+        ++ instc_insts_deps instc   where     toMungedPackageId :: Pretty id => ComponentInclude id rn -> MungedPackageId     toMungedPackageId ci =-        computeCompatPackageId-            (ci_pkgid ci)-            (case ci_cname ci of-                CLibName name -> name-                _ -> error $ prettyShow (rc_cid rc) ++-                        " depends on non-library " ++ prettyShow (ci_id ci))+      computeCompatPackageId+        (ci_pkgid ci)+        ( case ci_cname ci of+            CLibName name -> name+            _ ->+              error $+                prettyShow (rc_cid rc)+                  ++ " depends on non-library "+                  ++ prettyShow (ci_id ci)+        )  -- | Get the 'MungedPackageId' of a 'ReadyComponent' IF it is -- a library. rc_munged_id :: ReadyComponent -> MungedPackageId rc_munged_id rc =-    computeCompatPackageId-        (rc_pkgid rc)-        (case rc_component rc of-            CLib lib -> libName lib-            _ -> error "rc_munged_id: not library")+  computeCompatPackageId+    (rc_pkgid rc)+    ( case rc_component rc of+        CLib lib -> libName lib+        _ -> error "rc_munged_id: not library"+    )  instance Package ReadyComponent where-    packageId = rc_pkgid+  packageId = rc_pkgid  instance HasUnitId ReadyComponent where-    installedUnitId = rc_uid+  installedUnitId = rc_uid  instance IsNode ReadyComponent where-    type Key ReadyComponent = UnitId-    nodeKey = rc_uid-    nodeNeighbors rc =-      (case rc_i rc of-        Right inst | [] <- instc_insts inst-                   -> []-                   | otherwise-                   -> [newSimpleUnitId (rc_cid rc)]-        _ -> []) ++-      ordNub (map fst (rc_depends rc)) ++-      map ann_id (rc_exe_deps rc)+  type Key ReadyComponent = UnitId+  nodeKey = rc_uid+  nodeNeighbors rc =+    ( case rc_i rc of+        Right inst+          | [] <- instc_insts inst ->+              []+          | otherwise ->+              [newSimpleUnitId (rc_cid rc)]+        _ -> []+    )+      ++ ordNub (map fst (rc_depends rc))+      ++ map ann_id (rc_exe_deps rc)  dispReadyComponent :: ReadyComponent -> Doc dispReadyComponent rc =-    hang (text (case rc_i rc of-                    Left  _ -> "indefinite"-                    Right _ -> "definite")-            <+> pretty (nodeKey rc)-            {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} ) 4 $-        vcat [ text "depends" <+> pretty uid-             | uid <- nodeNeighbors rc ]+  hang+    ( text+        ( case rc_i rc of+            Left _ -> "indefinite"+            Right _ -> "definite"+        )+        <+> pretty (nodeKey rc)+        {- <+> dispModSubst (Map.fromList (lc_insts lc)) -}+    )+    4+    $ vcat+      [ text "depends" <+> pretty uid+      | uid <- nodeNeighbors rc+      ]  -- | The state of 'InstM'; a mapping from 'UnitId's to their -- ready component, or @Nothing@ if its an external@@ -189,22 +202,25 @@  -- | A state monad for doing instantiations (can't use actual -- State because that would be an extra dependency.)-newtype InstM a = InstM { runInstM :: InstS -> (a, InstS) }+newtype InstM a = InstM {runInstM :: InstS -> (a, InstS)}  instance Functor InstM where-    fmap f (InstM m) = InstM $ \s -> let (x, s') = m s-                                     in (f x, s')+  fmap f (InstM m) = InstM $ \s ->+    let (x, s') = m s+     in (f x, s')  instance Applicative InstM where-    pure a = InstM $ \s -> (a, s)-    InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s-                                            (x', s'') = x s'-                                        in (f' x', s'')+  pure a = InstM $ \s -> (a, s)+  InstM f <*> InstM x = InstM $ \s ->+    let (f', s') = f s+        (x', s'') = x s'+     in (f' x', s'')  instance Monad InstM where-    return = pure-    InstM m >>= f = InstM $ \s -> let (x, s') = m s-                                  in runInstM (f x) s'+  return = pure+  InstM m >>= f = InstM $ \s ->+    let (x, s') = m s+     in runInstM (f x) s'  -- | Given a list of 'LinkedComponent's, expand the module graph -- so that we have an instantiated graph containing all of the@@ -222,27 +238,30 @@ -- -- We also call 'improveUnitId' during this process, so that fully -- instantiated components are given 'HashedUnitId'.--- toReadyComponents-    :: Map UnitId MungedPackageId-    -> Map ModuleName Module -- subst for the public component-    -> [LinkedComponent]-    -> [ReadyComponent]-toReadyComponents pid_map subst0 comps-    = catMaybes (Map.elems ready_map)+  :: Map UnitId MungedPackageId+  -> Map ModuleName Module -- subst for the public component+  -> [LinkedComponent]+  -> [ReadyComponent]+toReadyComponents pid_map subst0 comps =+  catMaybes (Map.elems ready_map)   where-    cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ]+    cmap = Map.fromList [(lc_cid lc, lc) | lc <- comps] -    instantiateUnitId :: ComponentId -> Map ModuleName Module-                      -> InstM DefUnitId+    instantiateUnitId+      :: ComponentId+      -> Map ModuleName Module+      -> InstM DefUnitId     instantiateUnitId cid insts = InstM $ \s ->-        case Map.lookup uid s of-            Nothing ->-                -- Knot tied-                let (r, s') = runInstM (instantiateComponent uid cid insts)-                                       (Map.insert uid r s)-                in (def_uid, Map.insert uid r s')-            Just _ -> (def_uid, s)+      case Map.lookup uid s of+        Nothing ->+          -- Knot tied+          let (r, s') =+                runInstM+                  (instantiateComponent uid cid insts)+                  (Map.insert uid r s)+           in (def_uid, Map.insert uid r s')+        Just _ -> (def_uid, s)       where         -- The mkDefUnitId here indicates that we assume         -- that Cabal handles unit id hash allocation.@@ -252,125 +271,142 @@         uid = unDefUnitId def_uid      instantiateComponent-        :: UnitId -> ComponentId -> Map ModuleName Module-        -> InstM (Maybe ReadyComponent)+      :: UnitId+      -> ComponentId+      -> Map ModuleName Module+      -> InstM (Maybe ReadyComponent)     instantiateComponent uid cid insts       | Just lc <- Map.lookup cid cmap = do-            provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc))-            -- NB: lc_sig_includes is omitted here, because we don't-            -- need them to build-            includes <- forM (lc_includes lc) $ \ci -> do-                uid' <- substUnitId insts (ci_id ci)-                return ci { ci_ann_id = fmap (const uid') (ci_ann_id ci) }-            exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc)-            s <- InstM $ \s -> (s, s)-            let getDep (Module dep_def_uid _)-                    | let dep_uid = unDefUnitId dep_def_uid+          provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc))+          -- NB: lc_sig_includes is omitted here, because we don't+          -- need them to build+          includes <- forM (lc_includes lc) $ \ci -> do+            uid' <- substUnitId insts (ci_id ci)+            return ci{ci_ann_id = fmap (const uid') (ci_ann_id ci)}+          exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc)+          s <- InstM $ \s -> (s, s)+          let getDep (Module dep_def_uid _)+                | let dep_uid = unDefUnitId dep_def_uid =                     -- Lose DefUnitId invariant for rc_depends-                    = [(dep_uid,-                          fromMaybe err_pid $-                            Map.lookup dep_uid pid_map <|>-                            fmap rc_munged_id (join (Map.lookup dep_uid s)))]-                  where-                    err_pid = MungedPackageId-                        (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName)-                        (mkVersion [0])-                instc = InstantiatedComponent {-                            instc_insts = Map.toList insts,-                            instc_insts_deps = concatMap getDep (Map.elems insts),-                            instc_provides = provides,-                            instc_includes = includes-                            -- NB: there is no dependency on the-                            -- indefinite version of this instantiated package here,-                            -- as (1) it doesn't go in depends in the-                            -- IPI: it's not a run time dep, and (2)-                            -- we don't have to tell GHC about it, it-                            -- will match up the ComponentId-                            -- automatically-                        }-            return $ Just ReadyComponent {-                    rc_ann_id       = (lc_ann_id lc) { ann_id = uid },-                    rc_open_uid     = DefiniteUnitId (unsafeMkDefUnitId uid),-                    rc_cid          = lc_cid lc,-                    rc_component    = lc_component lc,-                    rc_exe_deps     = exe_deps,-                    rc_public       = lc_public lc,-                    rc_i            = Right instc-                   }+                    [+                      ( dep_uid+                      , fromMaybe err_pid $+                          Map.lookup dep_uid pid_map+                            <|> fmap rc_munged_id (join (Map.lookup dep_uid s))+                      )+                    ]+                where+                  err_pid =+                    MungedPackageId+                      (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName)+                      (mkVersion [0])+              instc =+                InstantiatedComponent+                  { instc_insts = Map.toList insts+                  , instc_insts_deps = concatMap getDep (Map.elems insts)+                  , instc_provides = provides+                  , instc_includes = includes+                  -- NB: there is no dependency on the+                  -- indefinite version of this instantiated package here,+                  -- as (1) it doesn't go in depends in the+                  -- IPI: it's not a run time dep, and (2)+                  -- we don't have to tell GHC about it, it+                  -- will match up the ComponentId+                  -- automatically+                  }+          return $+            Just+              ReadyComponent+                { rc_ann_id = (lc_ann_id lc){ann_id = uid}+                , rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid)+                , rc_cid = lc_cid lc+                , rc_component = lc_component lc+                , rc_exe_deps = exe_deps+                , rc_public = lc_public lc+                , rc_i = Right instc+                }       | otherwise = return Nothing      substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId     substUnitId _ (DefiniteUnitId uid) =-        return uid+      return uid     substUnitId subst (IndefFullUnitId cid insts) = do-        insts' <- substSubst subst insts-        instantiateUnitId cid insts'+      insts' <- substSubst subst insts+      instantiateUnitId cid insts'      -- NB: NOT composition-    substSubst :: Map ModuleName Module-               -> Map ModuleName OpenModule-               -> InstM (Map ModuleName Module)+    substSubst+      :: Map ModuleName Module+      -> Map ModuleName OpenModule+      -> InstM (Map ModuleName Module)     substSubst subst insts = traverse (substModule subst) insts      substModule :: Map ModuleName Module -> OpenModule -> InstM Module     substModule subst (OpenModuleVar mod_name)-        | Just m <- Map.lookup mod_name subst = return m-        | otherwise = error "substModule: non-closing substitution"+      | Just m <- Map.lookup mod_name subst = return m+      | otherwise = error "substModule: non-closing substitution"     substModule subst (OpenModule uid mod_name) = do-        uid' <- substUnitId subst uid-        return (Module uid' mod_name)+      uid' <- substUnitId subst uid+      return (Module uid' mod_name) -    substExeDep :: Map ModuleName Module-                -> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId)+    substExeDep+      :: Map ModuleName Module+      -> AnnotatedId OpenUnitId+      -> InstM (AnnotatedId UnitId)     substExeDep insts exe_aid = do-        exe_uid' <- substUnitId insts (ann_id exe_aid)-        return exe_aid { ann_id = unDefUnitId exe_uid' }+      exe_uid' <- substUnitId insts (ann_id exe_aid)+      return exe_aid{ann_id = unDefUnitId exe_uid'}      indefiniteUnitId :: ComponentId -> InstM UnitId     indefiniteUnitId cid = do-        let uid = newSimpleUnitId cid-        r <- indefiniteComponent uid cid-        InstM $ \s -> (uid, Map.insert uid r s)+      let uid = newSimpleUnitId cid+      r <- indefiniteComponent uid cid+      InstM $ \s -> (uid, Map.insert uid r s)      indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent)     indefiniteComponent uid cid       | Just lc <- Map.lookup cid cmap = do-            -- We're going to process includes, in case some of them-            -- are fully definite even without any substitution.  We-            -- want to build those too; see #5634.-            inst_includes <- forM (lc_includes lc) $ \ci ->-                if Set.null (openUnitIdFreeHoles (ci_id ci))-                    then do uid' <- substUnitId Map.empty (ci_id ci)-                            return $ ci { ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci) }-                    else return ci-            exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc)-            let indefc = IndefiniteComponent {-                        indefc_requires = map fst (lc_insts lc),-                        indefc_provides = modShapeProvides (lc_shape lc),-                        indefc_includes = inst_includes ++ lc_sig_includes lc-                    }-            return $ Just ReadyComponent {-                    rc_ann_id       = (lc_ann_id lc) { ann_id = uid },-                    rc_cid          = lc_cid lc,-                    rc_open_uid     = lc_uid lc,-                    rc_component    = lc_component lc,-                    -- It's always fully built-                    rc_exe_deps     = exe_deps,-                    rc_public       = lc_public lc,-                    rc_i            = Left indefc+          -- We're going to process includes, in case some of them+          -- are fully definite even without any substitution.  We+          -- want to build those too; see #5634.+          inst_includes <- forM (lc_includes lc) $ \ci ->+            if Set.null (openUnitIdFreeHoles (ci_id ci))+              then do+                uid' <- substUnitId Map.empty (ci_id ci)+                return $ ci{ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci)}+              else return ci+          exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc)+          let indefc =+                IndefiniteComponent+                  { indefc_requires = map fst (lc_insts lc)+                  , indefc_provides = modShapeProvides (lc_shape lc)+                  , indefc_includes = inst_includes ++ lc_sig_includes lc+                  }+          return $+            Just+              ReadyComponent+                { rc_ann_id = (lc_ann_id lc){ann_id = uid}+                , rc_cid = lc_cid lc+                , rc_open_uid = lc_uid lc+                , rc_component = lc_component lc+                , -- It's always fully built+                  rc_exe_deps = exe_deps+                , rc_public = lc_public lc+                , rc_i = Left indefc                 }       | otherwise = return Nothing      ready_map = snd $ runInstM work Map.empty      work-        -- Top-level instantiation per subst0-        | not (Map.null subst0)-        , [lc] <- filter lc_public (Map.elems cmap)-        = do _ <- instantiateUnitId (lc_cid lc) subst0-             return ()-        | otherwise-        = forM_ (Map.elems cmap) $ \lc ->+      -- Top-level instantiation per subst0+      | not (Map.null subst0)+      , [lc] <- filter lc_public (Map.elems cmap) =+          do+            _ <- instantiateUnitId (lc_cid lc) subst0+            return ()+      | otherwise =+          forM_ (Map.elems cmap) $ \lc ->             if null (lc_insts lc)-                then instantiateUnitId (lc_cid lc) Map.empty >> return ()-                else indefiniteUnitId (lc_cid lc) >> return ()+              then instantiateUnitId (lc_cid lc) Map.empty >> return ()+              else indefiniteUnitId (lc_cid lc) >> return ()
src/Distribution/Backpack/UnifyM.hs view
@@ -1,163 +1,163 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-}--- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.UnifyM (-    -- * Unification monad-    UnifyM,-    runUnifyM,-    failWith,-    addErr,-    failIfErrs,-    tryM,-    addErrContext,-    addErrContextM,-    liftST, -    UnifEnv(..),-    getUnifEnv,+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.UnifyM+  ( -- * Unification monad+    UnifyM+  , runUnifyM+  , failWith+  , addErr+  , failIfErrs+  , tryM+  , addErrContext+  , addErrContextM+  , liftST+  , UnifEnv (..)+  , getUnifEnv      -- * Modules and unit IDs-    ModuleU,-    ModuleU'(..),-    convertModule,-    convertModuleU,--    UnitIdU,-    UnitIdU'(..),-    convertUnitId,-    convertUnitIdU,--    ModuleSubstU,-    convertModuleSubstU,-    convertModuleSubst,--    ModuleScopeU,-    emptyModuleScopeU,-    convertModuleScopeU,--    ModuleWithSourceU,--    convertInclude,-    convertModuleProvides,-    convertModuleProvidesU,--) where+  , ModuleU+  , ModuleU' (..)+  , convertModule+  , convertModuleU+  , UnitIdU+  , UnitIdU' (..)+  , convertUnitId+  , convertUnitIdU+  , ModuleSubstU+  , convertModuleSubstU+  , convertModuleSubst+  , ModuleScopeU+  , emptyModuleScopeU+  , convertModuleScopeU+  , ModuleWithSourceU+  , convertInclude+  , convertModuleProvides+  , convertModuleProvidesU+  ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod)+import Prelude () -import Distribution.Backpack.ModuleShape-import Distribution.Backpack.ModuleScope-import Distribution.Backpack.ModSubst-import Distribution.Backpack.FullUnitId import Distribution.Backpack+import Distribution.Backpack.FullUnitId+import Distribution.Backpack.ModSubst+import Distribution.Backpack.ModuleScope+import Distribution.Backpack.ModuleShape -import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.ModuleName import Distribution.Package import Distribution.PackageDescription import Distribution.Pretty-import Distribution.Types.ComponentInclude import Distribution.Types.AnnotatedId+import Distribution.Types.ComponentInclude+import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.Verbosity -import Data.STRef-import Data.Traversable import Control.Monad.ST-import qualified Data.Map as Map-import qualified Data.Set as Set import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import Data.STRef+import qualified Data.Set as Set+import Data.Traversable import Text.PrettyPrint  -- TODO: more detailed trace output on high verbosity would probably -- be appreciated by users debugging unification errors.  Collect -- some good examples! -data ErrMsg = ErrMsg {-        err_msg :: Doc,-        err_ctx :: [Doc]-    }+data ErrMsg = ErrMsg+  { err_msg :: Doc+  , err_ctx :: [Doc]+  } type MsgDoc = Doc  renderErrMsg :: ErrMsg -> MsgDoc-renderErrMsg ErrMsg { err_msg = msg, err_ctx = ctx } =-    msg $$ vcat ctx+renderErrMsg ErrMsg{err_msg = msg, err_ctx = ctx} =+  msg $$ vcat ctx  -- | The unification monad, this monad encapsulates imperative -- unification.-newtype UnifyM s a = UnifyM { unUnifyM :: UnifEnv s -> ST s (Maybe a) }+newtype UnifyM s a = UnifyM {unUnifyM :: UnifEnv s -> ST s (Maybe a)}  -- | Run a computation in the unification monad. runUnifyM :: Verbosity -> ComponentId -> FullDb -> (forall s. UnifyM s a) -> Either [MsgDoc] a-runUnifyM verbosity self_cid db m-    = runST $ do i    <- newSTRef 0-                 hmap <- newSTRef Map.empty-                 errs <- newSTRef []-                 mb_r <- unUnifyM m UnifEnv {-                            unify_uniq = i,-                            unify_reqs = hmap,-                            unify_self_cid = self_cid,-                            unify_verbosity = verbosity,-                            unify_ctx = [],-                            unify_db = db,-                            unify_errs = errs }-                 final_errs <- readSTRef errs-                 case mb_r of-                    Just x | null final_errs -> return (Right x)-                    _ -> return (Left (map renderErrMsg (reverse final_errs)))+runUnifyM verbosity self_cid db m =+  runST $ do+    i <- newSTRef 0+    hmap <- newSTRef Map.empty+    errs <- newSTRef []+    mb_r <-+      unUnifyM+        m+        UnifEnv+          { unify_uniq = i+          , unify_reqs = hmap+          , unify_self_cid = self_cid+          , unify_verbosity = verbosity+          , unify_ctx = []+          , unify_db = db+          , unify_errs = errs+          }+    final_errs <- readSTRef errs+    case mb_r of+      Just x | null final_errs -> return (Right x)+      _ -> return (Left (map renderErrMsg (reverse final_errs)))+ -- NB: GHC 7.6 throws a hissy fit if you pattern match on 'm'.  type ErrCtx s = MsgDoc  -- | The unification environment.-data UnifEnv s = UnifEnv {-        -- | A supply of unique integers to label 'UnitIdU'-        -- cells.  This is used to determine loops in unit-        -- identifiers (which can happen with mutual recursion.)-        unify_uniq :: UnifRef s UnitIdUnique,-        -- | The set of requirements in scope.  When-        -- a provision is brought into scope, we unify with-        -- the requirement at the same module name to fill it.-        -- This mapping grows monotonically.-        unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)),-        -- | Component id of the unit we're linking.  We use this-        -- to detect if we fill a requirement with a local module,-        -- which in principle should be OK but is not currently-        -- supported by GHC.-        unify_self_cid :: ComponentId,-        -- | How verbose the error message should be-        unify_verbosity :: Verbosity,-        -- | The error reporting context-        unify_ctx :: [ErrCtx s],-        -- | The package index for expanding unit identifiers-        unify_db :: FullDb,-        -- | Accumulated errors-        unify_errs :: UnifRef s [ErrMsg]-    }+data UnifEnv s = UnifEnv+  { unify_uniq :: UnifRef s UnitIdUnique+  -- ^ A supply of unique integers to label 'UnitIdU'+  -- cells.  This is used to determine loops in unit+  -- identifiers (which can happen with mutual recursion.)+  , unify_reqs :: UnifRef s (Map ModuleName (ModuleU s))+  -- ^ The set of requirements in scope.  When+  -- a provision is brought into scope, we unify with+  -- the requirement at the same module name to fill it.+  -- This mapping grows monotonically.+  , unify_self_cid :: ComponentId+  -- ^ Component id of the unit we're linking.  We use this+  -- to detect if we fill a requirement with a local module,+  -- which in principle should be OK but is not currently+  -- supported by GHC.+  , unify_verbosity :: Verbosity+  -- ^ How verbose the error message should be+  , unify_ctx :: [ErrCtx s]+  -- ^ The error reporting context+  , unify_db :: FullDb+  -- ^ The package index for expanding unit identifiers+  , unify_errs :: UnifRef s [ErrMsg]+  -- ^ Accumulated errors+  }  instance Functor (UnifyM s) where-    fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m)+  fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m)  instance Applicative (UnifyM s) where-    pure = UnifyM . pure . pure . pure-    UnifyM f <*> UnifyM x = UnifyM $ \r -> do-        f' <- f r-        case f' of+  pure = UnifyM . pure . pure . pure+  UnifyM f <*> UnifyM x = UnifyM $ \r -> do+    f' <- f r+    case f' of+      Nothing -> return Nothing+      Just f'' -> do+        x' <- x r+        case x' of           Nothing -> return Nothing-          Just f'' -> do-              x' <- x r-              case x' of-                  Nothing -> return Nothing-                  Just x'' -> return (Just (f'' x''))+          Just x'' -> return (Just (f'' x''))  instance Monad (UnifyM s) where-    return = pure-    UnifyM m >>= f = UnifyM $ \r -> do-        x <- m r-        case x of-            Nothing -> return Nothing-            Just x' -> unUnifyM (f x') r+  return = pure+  UnifyM m >>= f = UnifyM $ \r -> do+    x <- m r+    case x of+      Nothing -> return Nothing+      Just x' -> unUnifyM (f x') r  -- | Lift a computation from 'ST' monad to 'UnifyM' monad. -- Internal use only.@@ -166,32 +166,35 @@  addErr :: MsgDoc -> UnifyM s () addErr msg = do-    env <- getUnifEnv-    let err = ErrMsg {-                err_msg = msg,-                err_ctx = unify_ctx env-              }-    liftST $ modifySTRef (unify_errs env) (\errs -> err:errs)+  env <- getUnifEnv+  let err =+        ErrMsg+          { err_msg = msg+          , err_ctx = unify_ctx env+          }+  liftST $ modifySTRef (unify_errs env) (\errs -> err : errs)  failWith :: MsgDoc -> UnifyM s a failWith msg = do-    addErr msg-    failM+  addErr msg+  failM  failM :: UnifyM s a failM = UnifyM $ \_ -> return Nothing  failIfErrs :: UnifyM s () failIfErrs = do-    env <- getUnifEnv-    errs <- liftST $ readSTRef (unify_errs env)-    when (not (null errs)) failM+  env <- getUnifEnv+  errs <- liftST $ readSTRef (unify_errs env)+  when (not (null errs)) failM  tryM :: UnifyM s a -> UnifyM s (Maybe a) tryM m =-    UnifyM (\env -> do+  UnifyM+    ( \env -> do         mb_r <- unUnifyM m env-        return (Just mb_r))+        return (Just mb_r)+    )  {- otherFail :: ErrMsg -> UnifyM s a@@ -236,8 +239,7 @@ -- | Add a message to the error context.  It may make monadic queries. addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a addErrContextM ctx m =-    UnifyM $ \r -> unUnifyM m r { unify_ctx = ctx : unify_ctx r }-+  UnifyM $ \r -> unUnifyM m r{unify_ctx = ctx : unify_ctx r}  ----------------------------------------------------------------------- -- The "unifiable" variants of the data types@@ -251,13 +253,13 @@  -- | Contents of a mutable 'ModuleU' reference. data ModuleU' s-    = ModuleU (UnitIdU s) ModuleName-    | ModuleVarU ModuleName+  = ModuleU (UnitIdU s) ModuleName+  | ModuleVarU ModuleName  -- | Contents of a mutable 'UnitIdU' reference. data UnitIdU' s-    = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s))-    | UnitIdThunkU DefUnitId+  = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s))+  | UnitIdThunkU DefUnitId  -- | A mutable version of 'Module' which can be imperatively unified. type ModuleU s = UnionFind.Point s (ModuleU' s)@@ -273,7 +275,6 @@ -- participate in unification! type UnitIdUnique = Int - ----------------------------------------------------------------------- -- Conversion to the unifiable data types @@ -286,7 +287,7 @@  extendMuEnv :: MuEnv s -> UnitIdU s -> MuEnv s extendMuEnv (m, i) x =-    (IntMap.insert (i + 1) x m, i + 1)+  (IntMap.insert (i + 1) x m, i + 1)  {- lookupMuEnv :: MuEnv s -> Int {- de Bruijn index -} -> UnitIdU s@@ -308,37 +309,42 @@ --     @hole:A@ binders. --   * @MuEnv@ - the environment for mu-binders. -convertUnitId' :: MuEnv s-               -> OpenUnitId-               -> UnifyM s (UnitIdU s)+convertUnitId'+  :: MuEnv s+  -> OpenUnitId+  -> UnifyM s (UnitIdU s) -- TODO: this could be more lazy if we know there are no internal -- references convertUnitId' _ (DefiniteUnitId uid) =-    liftST $ UnionFind.fresh (UnitIdThunkU uid)+  liftST $ UnionFind.fresh (UnitIdThunkU uid) convertUnitId' stk (IndefFullUnitId cid insts) = do-    fs <- fmap unify_uniq getUnifEnv-    x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later-    insts_u <- for insts $ convertModule' (extendMuEnv stk x)-    u <- readUnifRef fs-    writeUnifRef fs (u+1)-    y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u)-    liftST $ UnionFind.union x y-    return y+  fs <- fmap unify_uniq getUnifEnv+  x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later+  insts_u <- for insts $ convertModule' (extendMuEnv stk x)+  u <- readUnifRef fs+  writeUnifRef fs (u + 1)+  y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u)+  liftST $ UnionFind.union x y+  return y+ -- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i) -convertModule' :: MuEnv s-               -> OpenModule -> UnifyM s (ModuleU s)+convertModule'+  :: MuEnv s+  -> OpenModule+  -> UnifyM s (ModuleU s) convertModule' _stk (OpenModuleVar mod_name) = do-    hmap <- fmap unify_reqs getUnifEnv-    hm <- readUnifRef hmap-    case Map.lookup mod_name hm of-        Nothing -> do mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name)-                      writeUnifRef hmap (Map.insert mod_name mod hm)-                      return mod-        Just mod -> return mod+  hmap <- fmap unify_reqs getUnifEnv+  hm <- readUnifRef hmap+  case Map.lookup mod_name hm of+    Nothing -> do+      mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name)+      writeUnifRef hmap (Map.insert mod_name mod hm)+      return mod+    Just mod -> return mod convertModule' stk (OpenModule uid mod_name) = do-    uid_u <- convertUnitId' stk uid-    liftST $ UnionFind.fresh (ModuleU uid_u mod_name)+  uid_u <- convertUnitId' stk uid+  liftST $ UnionFind.fresh (ModuleU uid_u mod_name)  convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s) convertUnitId = convertUnitId' emptyMuEnv@@ -346,8 +352,6 @@ convertModule :: OpenModule -> UnifyM s (ModuleU s) convertModule = convertModule' emptyMuEnv -- ----------------------------------------------------------------------- -- Substitutions @@ -380,38 +384,50 @@  lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int lookupMooEnv (m, i) k =-    case IntMap.lookup k m of-        Nothing -> Nothing-        Just v -> Just (i-v) -- de Bruijn indexize+  case IntMap.lookup k m of+    Nothing -> Nothing+    Just v -> Just (i - v) -- de Bruijn indexize  -- The workhorse functions -convertUnitIdU' :: MooEnv -> UnitIdU s -> UnifyM s OpenUnitId-convertUnitIdU' stk uid_u = do-    x <- liftST $ UnionFind.find uid_u-    case x of-        UnitIdThunkU uid -> return (DefiniteUnitId uid)-        UnitIdU u cid insts_u ->-            case lookupMooEnv stk u of-                Just _i ->-                    failWith (text "Unsupported mutually recursive unit identifier")-                    -- return (UnitIdVar i)-                Nothing -> do-                    insts <- for insts_u $ convertModuleU' (extendMooEnv stk u)-                    return (IndefFullUnitId cid insts)+-- | Returns `OpenUnitId` if there is no a mutually recursive unit.+-- | Otherwise returns a list of signatures instantiated by given `UnitIdU`.+convertUnitIdU' :: MooEnv -> UnitIdU s -> Doc -> UnifyM s OpenUnitId+convertUnitIdU' stk uid_u required_mod_name = do+  x <- liftST $ UnionFind.find uid_u+  case x of+    UnitIdThunkU uid -> return $ DefiniteUnitId uid+    UnitIdU u cid insts_u ->+      case lookupMooEnv stk u of+        Just _ ->+          let mod_names = Map.keys insts_u+           in failWithMutuallyRecursiveUnitsError required_mod_name mod_names+        Nothing -> do+          insts <- for insts_u $ convertModuleU' (extendMooEnv stk u)+          return $ IndefFullUnitId cid insts  convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule convertModuleU' stk mod_u = do-    mod <- liftST $ UnionFind.find mod_u-    case mod of-        ModuleVarU mod_name -> return (OpenModuleVar mod_name)-        ModuleU uid_u mod_name -> do-            uid <- convertUnitIdU' stk uid_u-            return (OpenModule uid mod_name)+  mod <- liftST $ UnionFind.find mod_u+  case mod of+    ModuleVarU mod_name -> return (OpenModuleVar mod_name)+    ModuleU uid_u mod_name -> do+      uid <- convertUnitIdU' stk uid_u (pretty mod_name)+      return (OpenModule uid mod_name) +failWithMutuallyRecursiveUnitsError :: Doc -> [ModuleName] -> UnifyM s a+failWithMutuallyRecursiveUnitsError required_mod_name mod_names =+  let sigsList = hcat $ punctuate (text ", ") $ map (quotes . pretty) mod_names+   in failWith $+        text "Cannot instantiate requirement"+          <+> quotes required_mod_name+          $$ text "Ensure \"build-depends:\" doesn't include any library with signatures:"+          <+> sigsList+          $$ text "as this creates a cyclic dependency, which GHC does not support."+ -- Helper functions -convertUnitIdU :: UnitIdU s -> UnifyM s OpenUnitId+convertUnitIdU :: UnitIdU s -> Doc -> UnifyM s OpenUnitId convertUnitIdU = convertUnitIdU' emptyMooEnv  convertModuleU :: ModuleU s -> UnifyM s OpenModule@@ -421,11 +437,12 @@ emptyModuleScopeU :: ModuleScopeU s emptyModuleScopeU = (Map.empty, Map.empty) - -- | The mutable counterpart of 'ModuleScope'. type ModuleScopeU s = (ModuleProvidesU s, ModuleRequiresU s)+ -- | The mutable counterpart of 'ModuleProvides' type ModuleProvidesU s = Map ModuleName [ModuleWithSourceU s]+ type ModuleRequiresU s = ModuleProvidesU s type ModuleWithSourceU s = WithSource (ModuleU s) @@ -437,33 +454,41 @@   where     pn = pkgName (ci_pkgid ci)     pp_pn =-        case ci_cname ci of-            CLibName LMainLibName -> pretty pn-            CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn-            -- Shouldn't happen-            cn -> pretty pn <+> parens (pretty cn)+      case ci_cname ci of+        CLibName LMainLibName -> pretty pn+        CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn+        -- Shouldn't happen+        cn -> pretty pn <+> parens (pretty cn)  -- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do -- unification on it. convertInclude-    :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming-    -> UnifyM s (ModuleScopeU s,-                 Either (ComponentInclude (UnitIdU s) ModuleRenaming) {- normal -}-                        (ComponentInclude (UnitIdU s) ModuleRenaming) {- sig -})-convertInclude ci@(ComponentInclude {-                    ci_ann_id = AnnotatedId {-                            ann_id = (uid, ModuleShape provs reqs),-                            ann_pid = pid,-                            ann_cname = compname-                        },-                    ci_renaming = incl@(IncludeRenaming prov_rns req_rns),-                    ci_implicit = implicit-               }) = addErrContext (text "In" <+> ci_msg ci) $ do+  :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming+  -> UnifyM+      s+      ( ModuleScopeU s+      , Either+          (ComponentInclude (UnitIdU s) ModuleRenaming {- normal -})+          (ComponentInclude (UnitIdU s) ModuleRenaming {- sig -})+      )+convertInclude+  ci@( ComponentInclude+        { ci_ann_id =+          AnnotatedId+            { ann_id = (uid, ModuleShape provs reqs)+            , ann_pid = pid+            , ann_cname = compname+            }+        , ci_renaming = incl@(IncludeRenaming prov_rns req_rns)+        , ci_implicit = implicit+        }+      ) = addErrContext (text "In" <+> ci_msg ci) $ do     let pn = packageName pid-        the_source | implicit-                   = FromBuildDepends pn compname-                   | otherwise-                   = FromMixins pn compname incl+        the_source+          | implicit =+              FromBuildDepends pn compname+          | otherwise =+              FromMixins pn compname incl         source = WithSource the_source      -- Suppose our package has two requirements A and B, and@@ -488,27 +513,31 @@       case req_rns of         DefaultRenaming -> return []         HidingRenaming _ -> do-            -- Not valid here for requires!-            addErr $ text "Unsupported syntax" <+>-                     quotes (text "requires hiding (...)")-            return []+          -- Not valid here for requires!+          addErr $+            text "Unsupported syntax"+              <+> quotes (text "requires hiding (...)")+          return []         ModuleRenaming rns -> return rns      let req_rename_listmap :: Map ModuleName [ModuleName]         req_rename_listmap =-            Map.fromListWith (++) [ (k,[v]) | (k,v) <- req_rename_list ]+          Map.fromListWith (++) [(k, [v]) | (k, v) <- req_rename_list]     req_rename <- sequenceA . flip Map.mapWithKey req_rename_listmap $ \k vs0 ->       case vs0 of-        []  -> error "req_rename"+        [] -> error "req_rename"         [v] -> return v-        v:vs -> do addErr $-                    text "Conflicting renamings of requirement" <+> quotes (pretty k) $$-                    text "Renamed to: " <+> vcat (map pretty (v:vs))-                   return v+        v : vs -> do+          addErr $+            text "Conflicting renamings of requirement"+              <+> quotes (pretty k)+              $$ text "Renamed to: "+              <+> vcat (map pretty (v : vs))+          return v      let req_rename_fn k = case Map.lookup k req_rename of-                            Nothing -> k-                            Just v  -> v+          Nothing -> k+          Just v -> v      -- Requirement substitution.     --@@ -523,19 +552,25 @@     -- mappings.     --     --      A -> X      ==>     X -> <X>, B -> <B>-    reqs_u <- convertModuleRequires . Map.fromList $-                [ (k, [source (OpenModuleVar k)])-                | k <- map req_rename_fn (Set.toList reqs)-                ]+    reqs_u <-+      convertModuleRequires . Map.fromList $+        [ (k, [source (OpenModuleVar k)])+        | k <- map req_rename_fn (Set.toList reqs)+        ]      -- Report errors if there were unused renamings     let leftover = Map.keysSet req_rename `Set.difference` reqs     unless (Set.null leftover) $-        addErr $-            hang (text "The" <+> text (showComponentName compname) <+>-                  text "from package" <+> quotes (pretty pid)-                  <+> text "does not require:") 4-                 (vcat (map pretty (Set.toList leftover)))+      addErr $+        hang+          ( text "The"+              <+> text (showComponentName compname)+              <+> text "from package"+              <+> quotes (pretty pid)+              <+> text "does not require:"+          )+          4+          (vcat (map pretty (Set.toList leftover)))      -- Provision computation is more complex.     -- For example, if we have:@@ -559,56 +594,72 @@     -- Importantly, overlapping rename targets get accumulated     -- together.  It's not an (immediate) error.     (pre_prov_scope, prov_rns') <--        case prov_rns of-            DefaultRenaming -> return (Map.toList provs, prov_rns)-            HidingRenaming hides ->-                let hides_set = Set.fromList hides-                in let r = [ (k,v)-                           | (k,v) <- Map.toList provs-                           , not (k `Set.member` hides_set) ]-                   -- GHC doesn't understand hiding, so expand it out!-                   in return (r, ModuleRenaming (map ((\x -> (x,x)).fst) r))-            ModuleRenaming rns -> do-              r <- sequence-                [ case Map.lookup from provs of-                    Just m -> return (to, m)-                    Nothing -> failWith $-                        text "Package" <+> quotes (pretty pid) <+>-                        text "does not expose the module" <+> quotes (pretty from)-                | (from, to) <- rns ]-              return (r, prov_rns)-    let prov_scope = modSubst req_subst-                   $ Map.fromListWith (++)-                   [ (k, [source v])-                   | (k, v) <- pre_prov_scope ]+      case prov_rns of+        DefaultRenaming -> return (Map.toList provs, prov_rns)+        HidingRenaming hides ->+          let hides_set = Set.fromList hides+           in let r =+                    [ (k, v)+                    | (k, v) <- Map.toList provs+                    , not (k `Set.member` hides_set)+                    ]+               in -- GHC doesn't understand hiding, so expand it out!+                  return (r, ModuleRenaming (map ((\x -> (x, x)) . fst) r))+        ModuleRenaming rns -> do+          r <-+            sequence+              [ case Map.lookup from provs of+                Just m -> return (to, m)+                Nothing ->+                  failWith $+                    text "Package"+                      <+> quotes (pretty pid)+                      <+> text "does not expose the module"+                      <+> quotes (pretty from)+              | (from, to) <- rns+              ]+          return (r, prov_rns)+    let prov_scope =+          modSubst req_subst $+            Map.fromListWith+              (++)+              [ (k, [source v])+              | (k, v) <- pre_prov_scope+              ]      provs_u <- convertModuleProvides prov_scope      -- TODO: Assert that provs_u is empty if provs was empty-    return ((provs_u, reqs_u),-                -- NB: We test that requirements is not null so that-                -- users can create packages with zero module exports-                -- that cause some C library to linked in, etc.-                (if Map.null provs && not (Set.null reqs)-                    then Right -- is sig-                    else Left) (ComponentInclude {-                                    ci_ann_id = AnnotatedId {-                                            ann_id = uid_u,-                                            ann_pid = pid,-                                            ann_cname = compname-                                        },-                                    ci_renaming = prov_rns',-                                    ci_implicit = ci_implicit ci-                                    }))+    return+      ( (provs_u, reqs_u)+      , -- NB: We test that requirements is not null so that+        -- users can create packages with zero module exports+        -- that cause some C library to linked in, etc.+        ( if Map.null provs && not (Set.null reqs)+            then Right -- is sig+            else Left+        )+          ( ComponentInclude+              { ci_ann_id =+                  AnnotatedId+                    { ann_id = uid_u+                    , ann_pid = pid+                    , ann_cname = compname+                    }+              , ci_renaming = prov_rns'+              , ci_implicit = ci_implicit ci+              }+          )+      )  -- | Convert a 'ModuleScopeU' to a 'ModuleScope'. convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope convertModuleScopeU (provs_u, reqs_u) = do-    provs <- convertModuleProvidesU provs_u-    reqs  <- convertModuleRequiresU reqs_u-    -- TODO: Test that the requirements are still free. If they-    -- are not, they got unified, and that's dodgy at best.-    return (ModuleScope provs reqs)+  provs <- convertModuleProvidesU provs_u+  reqs <- convertModuleRequiresU reqs_u+  -- TODO: Test that the requirements are still free. If they+  -- are not, they got unified, and that's dodgy at best.+  return (ModuleScope provs reqs)  -- | Convert a 'ModuleProvides' to a 'ModuleProvidesU' convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s)
− src/Distribution/CabalSpecVersion.hs 
@@ -1,150 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.CabalSpecVersion where--import Prelude ()-import Distribution.Compat.Prelude---- | Different Cabal-the-spec versions.------ We branch based on this at least in the parser.----data CabalSpecVersion-    = CabalSpecV1_0 -- ^ this is older than 'CabalSpecV1_2'-    | CabalSpecV1_2 -- ^ new syntax (sections)-    | CabalSpecV1_4-    | CabalSpecV1_6-    | CabalSpecV1_8-    | CabalSpecV1_10-    | CabalSpecV1_12-    -- 1.16 -- 1.14: no changes-    | CabalSpecV1_18-    | CabalSpecV1_20-    | CabalSpecV1_22-    | CabalSpecV1_24-    | CabalSpecV2_0-    | CabalSpecV2_2-    | CabalSpecV2_4-    | CabalSpecV3_0-    -- 3.2: no changes-    | CabalSpecV3_4-    | CabalSpecV3_6-  deriving (Eq, Ord, Show, Read, Enum, Bounded, Typeable, Data, Generic)--instance Binary CabalSpecVersion-instance Structured CabalSpecVersion-instance NFData CabalSpecVersion where rnf = genericRnf---- | Show cabal spec version, but not the way in the .cabal files------ @since 3.0.0.0-showCabalSpecVersion :: CabalSpecVersion -> String-showCabalSpecVersion CabalSpecV3_6  = "3.6"-showCabalSpecVersion CabalSpecV3_4  = "3.4"-showCabalSpecVersion CabalSpecV3_0  = "3.0"-showCabalSpecVersion CabalSpecV2_4  = "2.4"-showCabalSpecVersion CabalSpecV2_2  = "2.2"-showCabalSpecVersion CabalSpecV2_0  = "2.0"-showCabalSpecVersion CabalSpecV1_24 = "1.24"-showCabalSpecVersion CabalSpecV1_22 = "1.22"-showCabalSpecVersion CabalSpecV1_20 = "1.20"-showCabalSpecVersion CabalSpecV1_18 = "1.18"-showCabalSpecVersion CabalSpecV1_12 = "1.12"-showCabalSpecVersion CabalSpecV1_10 = "1.10"-showCabalSpecVersion CabalSpecV1_8  = "1.8"-showCabalSpecVersion CabalSpecV1_6  = "1.6"-showCabalSpecVersion CabalSpecV1_4  = "1.4"-showCabalSpecVersion CabalSpecV1_2  = "1.2"-showCabalSpecVersion CabalSpecV1_0  = "1.0"--cabalSpecLatest :: CabalSpecVersion-cabalSpecLatest = CabalSpecV3_6---- | Parse 'CabalSpecVersion' from version digits.------ It may fail if for recent versions the version is not exact.----cabalSpecFromVersionDigits :: [Int] -> Maybe CabalSpecVersion-cabalSpecFromVersionDigits v-    | v == [3,6]  = Just CabalSpecV3_6-    | v == [3,4]  = Just CabalSpecV3_4-    | v == [3,0]  = Just CabalSpecV3_0-    | v == [2,4]  = Just CabalSpecV2_4-    | v == [2,2]  = Just CabalSpecV2_2-    | v == [2,0]  = Just CabalSpecV2_0-    | v >= [1,25] = Nothing-    | v >= [1,23] = Just CabalSpecV1_24-    | v >= [1,21] = Just CabalSpecV1_22-    | v >= [1,19] = Just CabalSpecV1_20-    | v >= [1,17] = Just CabalSpecV1_18-    | v >= [1,11] = Just CabalSpecV1_12-    | v >= [1,9]  = Just CabalSpecV1_10-    | v >= [1,7]  = Just CabalSpecV1_8-    | v >= [1,5]  = Just CabalSpecV1_6-    | v >= [1,3]  = Just CabalSpecV1_4-    | v >= [1,1]  = Just CabalSpecV1_2-    | otherwise   = Just CabalSpecV1_0---- | @since 3.4.0.0-cabalSpecToVersionDigits :: CabalSpecVersion -> [Int]-cabalSpecToVersionDigits CabalSpecV3_6   = [3,6]-cabalSpecToVersionDigits CabalSpecV3_4   = [3,4]-cabalSpecToVersionDigits CabalSpecV3_0   = [3,0]-cabalSpecToVersionDigits CabalSpecV2_4   = [2,4]-cabalSpecToVersionDigits CabalSpecV2_2   = [2,2]-cabalSpecToVersionDigits CabalSpecV2_0   = [2,0]-cabalSpecToVersionDigits CabalSpecV1_24  = [1,24]-cabalSpecToVersionDigits CabalSpecV1_22  = [1,22]-cabalSpecToVersionDigits CabalSpecV1_20  = [1,20]-cabalSpecToVersionDigits CabalSpecV1_18  = [1,18]-cabalSpecToVersionDigits CabalSpecV1_12  = [1,12]-cabalSpecToVersionDigits CabalSpecV1_10  = [1,10]-cabalSpecToVersionDigits CabalSpecV1_8   = [1,8]-cabalSpecToVersionDigits CabalSpecV1_6   = [1,6]-cabalSpecToVersionDigits CabalSpecV1_4   = [1,4]-cabalSpecToVersionDigits CabalSpecV1_2   = [1,2]-cabalSpecToVersionDigits CabalSpecV1_0   = [1,0]---- | What is the minimum Cabal library version which knows how handle--- this spec version.------ /Note:/ this is a point where we could decouple cabal-spec and Cabal--- versions, if we ever want that.------ >>> cabalSpecMinimumLibraryVersion CabalSpecV3_0--- [2,5]------ >>> cabalSpecMinimumLibraryVersion CabalSpecV2_4--- [2,3]------ @since 3.4.0.0-cabalSpecMinimumLibraryVersion :: CabalSpecVersion -> [Int]-cabalSpecMinimumLibraryVersion CabalSpecV1_0 = [1,0]-cabalSpecMinimumLibraryVersion csv = case cabalSpecToVersionDigits (pred csv) of-    [x,y] -> [x, y+1]-    xs    -> xs--specHasCommonStanzas :: CabalSpecVersion -> HasCommonStanzas-specHasCommonStanzas v =-    if v >= CabalSpecV2_2-    then HasCommonStanzas-    else NoCommonStanzas--specHasElif :: CabalSpecVersion -> HasElif-specHasElif v = -    if v >= CabalSpecV2_2-    then HasElif-    else NoElif------------------------------------------------------------------------------------ Booleans------------------------------------------------------------------------------------ IDEA: make some kind of tagged booleans?-data HasElif = HasElif | NoElif-  deriving (Eq, Show)--data HasCommonStanzas = HasCommonStanzas | NoCommonStanzas-  deriving (Eq, Show)--data HasGlobstar = HasGlobstar | NoGlobstar
src/Distribution/Compat/Async.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-} -- | 'Async', yet using 'MVar's. -- -- Adopted from @async@ library@@ -7,35 +5,46 @@ -- Licensed under BSD-3-Clause -- -- @since 3.2.0.0----module Distribution.Compat.Async (-    AsyncM,-    withAsync, waitCatch,-    wait, asyncThreadId,-    cancel, uninterruptibleCancel, AsyncCancelled (..),+module Distribution.Compat.Async+  ( AsyncM+  , withAsync+  , waitCatch+  , wait+  , asyncThreadId+  , cancel+  , uninterruptibleCancel+  , AsyncCancelled (..)+     -- * Cabal extras-    withAsyncNF,-    ) where+  , withAsyncNF+  ) where -import Control.Concurrent      (ThreadId, forkIO)+import Control.Concurrent (ThreadId, forkIO) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)-import Control.DeepSeq         (NFData, force)+import Control.DeepSeq (NFData, force) import Control.Exception-       (BlockedIndefinitelyOnMVar (..), Exception (..), SomeException (..), catch, evaluate, mask, throwIO, throwTo, try, uninterruptibleMask_)-import Control.Monad           (void)-import Data.Typeable           (Typeable)-import GHC.Exts                (inline)--#if MIN_VERSION_base(4,7,0)-import Control.Exception (asyncExceptionFromException, asyncExceptionToException)-#endif+  ( BlockedIndefinitelyOnMVar (..)+  , Exception (..)+  , SomeException (..)+  , asyncExceptionFromException+  , asyncExceptionToException+  , catch+  , evaluate+  , mask+  , throwIO+  , throwTo+  , try+  , uninterruptibleMask_+  )+import Control.Monad (void)+import GHC.Exts (inline)  -- | Async, but based on 'MVar', as we don't depend on @stm@. data AsyncM a = Async   { asyncThreadId :: {-# UNPACK #-} !ThreadId-                  -- ^ Returns the 'ThreadId' of the thread running-                  -- the given 'Async'.-  , _asyncMVar    :: MVar (Either SomeException a)+  -- ^ Returns the 'ThreadId' of the thread running+  -- the given 'Async'.+  , _asyncMVar :: MVar (Either SomeException a)   }  -- | Spawn an asynchronous action in a separate thread, and pass its@@ -52,12 +61,12 @@ -- Note: a reference to the child thread is kept alive until the call -- to `withAsync` returns, so nesting many `withAsync` calls requires -- linear memory.--- withAsync :: IO a -> (AsyncM a -> IO b) -> IO b withAsync = inline withAsyncUsing forkIO  withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b-withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) where+withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF)+  where     evaluateNF = evaluate . force  withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b@@ -68,7 +77,8 @@   mask $ \restore -> do     t <- doFork $ try (restore action) >>= putMVar var     let a = Async t var-    r <- restore (inner a) `catchAll` \e -> do+    r <-+      restore (inner a) `catchAll` \e -> do         uninterruptibleCancel a         throwIO e     uninterruptibleCancel a@@ -79,21 +89,19 @@ -- exception is re-thrown by 'wait'. -- -- > wait = atomically . waitSTM--- {-# INLINE wait #-} wait :: AsyncM a -> IO a wait a = do-    res <- waitCatch a-    case res of-        Left (SomeException e) -> throwIO e-        Right x                -> return x+  res <- waitCatch a+  case res of+    Left (SomeException e) -> throwIO e+    Right x -> return x  -- | Wait for an asynchronous action to complete, and return either -- @Left e@ if the action raised an exception @e@, or @Right a@ if it -- returned a value @a@. -- -- > waitCatch = atomically . waitCatchSTM--- {-# INLINE waitCatch #-} waitCatch :: AsyncM a -> IO (Either SomeException a) waitCatch (Async _ var) = tryAgain (readMVar var)@@ -123,22 +131,21 @@ {-# INLINE cancel #-} cancel :: AsyncM a -> IO () cancel a@(Async t _) = do-    throwTo t AsyncCancelled-    void (waitCatch a)+  throwTo t AsyncCancelled+  void (waitCatch a)  -- | The exception thrown by `cancel` to terminate a thread. data AsyncCancelled = AsyncCancelled-  deriving (Show, Eq-    , Typeable+  deriving+    ( Show+    , Eq     )  instance Exception AsyncCancelled where-#if MIN_VERSION_base(4,7,0)   -- wraps in SomeAsyncException   -- See https://github.com/ghc/ghc/commit/756a970eacbb6a19230ee3ba57e24999e4157b09   fromException = asyncExceptionFromException   toException = asyncExceptionToException-#endif  -- | Cancel an asynchronous action --
− src/Distribution/Compat/Binary.hs 
@@ -1,71 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 711-{-# LANGUAGE PatternSynonyms #-}-#endif--#ifndef MIN_VERSION_binary-#define MIN_VERSION_binary(x, y, z) 0-#endif--module Distribution.Compat.Binary-       ( decodeOrFailIO-       , decodeFileOrFail'-#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0)-       , module Data.Binary-#else-       , Binary(..)-       , decode, encode, encodeFile-#endif-       ) where--import Control.Exception (ErrorCall (..), catch, evaluate)-import Data.ByteString.Lazy (ByteString)--#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0)--import Data.Binary---- | Lazily reconstruct a value previously written to a file.-decodeFileOrFail' :: Binary a => FilePath -> IO (Either String a)-decodeFileOrFail' f = either (Left . snd) Right `fmap` decodeFileOrFail f--#else--import Data.Binary.Get-import Data.Binary.Put-import qualified Data.ByteString.Lazy as BSL--import Distribution.Compat.Binary.Class-import Distribution.Compat.Binary.Generic ()---- | Decode a value from a lazy ByteString, reconstructing the--- original structure.----decode :: Binary a => ByteString -> a-decode = runGet get---- | Encode a value using binary serialisation to a lazy ByteString.----encode :: Binary a => a -> ByteString-encode = runPut . put-{-# INLINE encode #-}---- | Lazily reconstruct a value previously written to a file.-decodeFileOrFail' :: Binary a => FilePath -> IO (Either String a)-decodeFileOrFail' f = decodeOrFailIO =<< BSL.readFile f---- | Lazily serialise a value to a file-encodeFile :: Binary a => FilePath -> a -> IO ()-encodeFile f = BSL.writeFile f . encode--#endif--decodeOrFailIO :: Binary a => ByteString -> IO (Either String a)-decodeOrFailIO bs =-    catch (evaluate (decode bs) >>= return . Right) handler-  where-#if MIN_VERSION_base(4,9,0)-    handler (ErrorCallWithLocation str _) = return $ Left str-#else-    handler (ErrorCall str) = return $ Left str-#endif
− src/Distribution/Compat/Binary/Class.hs 
@@ -1,519 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE DefaultSignatures #-}--------------------------------------------------------------------------------- |--- Module      : Distribution.Compat.Binary.Class--- Copyright   : Lennart Kolmodin--- License     : BSD3-style (see LICENSE)------ Maintainer  : Lennart Kolmodin <kolmodin@gmail.com>--- Stability   : unstable--- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances------ Typeclass and instances for binary serialization.-----------------------------------------------------------------------------------module Distribution.Compat.Binary.Class (--    -- * The Binary class-      Binary(..)--    -- * Support for generics-    , GBinary(..)--    ) where--import Data.Word--import Data.Binary.Put-import Data.Binary.Get--import Control.Applicative ((<$>), (<*>), (*>))-import Foreign--import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as L--import Data.Char     (chr,ord)-import Data.List     (unfoldr)-import Data.Foldable (traverse_)---- And needed for the instances:-import qualified Data.ByteString as B-import qualified Data.Map        as Map-import qualified Data.Set        as Set-import qualified Data.IntMap     as IntMap-import qualified Data.IntSet     as IntSet-import qualified Data.Ratio      as R--import qualified Data.Tree as T--import Data.Array.Unboxed--import GHC.Generics--import qualified Data.Sequence as Seq-import qualified Data.Foldable as Fold----------------------------------------------------------------------------class GBinary f where-    gput :: f t -> Put-    gget :: Get (f t)---- | The 'Binary' class provides 'put' and 'get', methods to encode and--- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and--- 'Show' classes for textual representation of Haskell types, and is--- suitable for serialising Haskell values to disk, over the network.------ For decoding and generating simple external binary formats (e.g. C--- structures), Binary may be used, but in general is not suitable--- for complex protocols. Instead use the 'Put' and 'Get' primitives--- directly.------ Instances of Binary should satisfy the following property:------ > decode . encode == id------ That is, the 'get' and 'put' methods should be the inverse of each--- other. A range of instances are provided for basic Haskell types.----class Binary t where-    -- | Encode a value in the Put monad.-    put :: t -> Put-    -- | Decode a value in the Get monad-    get :: Get t--    default put :: (Generic t, GBinary (Rep t)) => t -> Put-    put = gput . from--    default get :: (Generic t, GBinary (Rep t)) => Get t-    get = to `fmap` gget----------------------------------------------------------------------------- Simple instances---- The () type need never be written to disk: values of singleton type--- can be reconstructed from the type alone-instance Binary () where-    put ()  = return ()-    get     = return ()---- Bools are encoded as a byte in the range 0 .. 1-instance Binary Bool where-    put     = putWord8 . fromIntegral . fromEnum-    get     = fmap (toEnum . fromIntegral) getWord8---- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2-instance Binary Ordering where-    put     = putWord8 . fromIntegral . fromEnum-    get     = fmap (toEnum . fromIntegral) getWord8----------------------------------------------------------------------------- Words and Ints---- Words8s are written as bytes-instance Binary Word8 where-    put     = putWord8-    get     = getWord8---- Words16s are written as 2 bytes in big-endian (network) order-instance Binary Word16 where-    put     = putWord16be-    get     = getWord16be---- Words32s are written as 4 bytes in big-endian (network) order-instance Binary Word32 where-    put     = putWord32be-    get     = getWord32be---- Words64s are written as 8 bytes in big-endian (network) order-instance Binary Word64 where-    put     = putWord64be-    get     = getWord64be---- Int8s are written as a single byte.-instance Binary Int8 where-    put i   = put (fromIntegral i :: Word8)-    get     = fmap fromIntegral (get :: Get Word8)---- Int16s are written as a 2 bytes in big endian format-instance Binary Int16 where-    put i   = put (fromIntegral i :: Word16)-    get     = fmap fromIntegral (get :: Get Word16)---- Int32s are written as a 4 bytes in big endian format-instance Binary Int32 where-    put i   = put (fromIntegral i :: Word32)-    get     = fmap fromIntegral (get :: Get Word32)---- Int64s are written as a 4 bytes in big endian format-instance Binary Int64 where-    put i   = put (fromIntegral i :: Word64)-    get     = fmap fromIntegral (get :: Get Word64)------------------------------------------------------------------------------ Words are are written as Word64s, that is, 8 bytes in big endian format-instance Binary Word where-    put i   = put (fromIntegral i :: Word64)-    get     = fmap fromIntegral (get :: Get Word64)---- Ints are are written as Int64s, that is, 8 bytes in big endian format-instance Binary Int where-    put i   = put (fromIntegral i :: Int64)-    get     = fmap fromIntegral (get :: Get Int64)-------------------------------------------------------------------------------- Portable, and pretty efficient, serialisation of Integer------- Fixed-size type for a subset of Integer-type SmallInt = Int32---- Integers are encoded in two ways: if they fit inside a SmallInt,--- they're written as a byte tag, and that value.  If the Integer value--- is too large to fit in a SmallInt, it is written as a byte array,--- along with a sign and length field.--instance Binary Integer where--    {-# INLINE put #-}-    put n | n >= lo && n <= hi = do-        putWord8 0-        put (fromIntegral n :: SmallInt)  -- fast path-     where-        lo = fromIntegral (minBound :: SmallInt) :: Integer-        hi = fromIntegral (maxBound :: SmallInt) :: Integer--    put n = do-        putWord8 1-        put sign-        put (unroll (abs n))         -- unroll the bytes-     where-        sign = fromIntegral (signum n) :: Word8--    {-# INLINE get #-}-    get = do-        tag <- get :: Get Word8-        case tag of-            0 -> fmap fromIntegral (get :: Get SmallInt)-            _ -> do sign  <- get-                    bytes <- get-                    let v = roll bytes-                    return $! if sign == (1 :: Word8) then v else - v------- Fold and unfold an Integer to and from a list of its bytes----unroll :: Integer -> [Word8]-unroll = unfoldr step-  where-    step 0 = Nothing-    step i = Just (fromIntegral i, i `shiftR` 8)--roll :: [Word8] -> Integer-roll   = foldr unstep 0-  where-    unstep b a = a `shiftL` 8 .|. fromIntegral b--{-------- An efficient, raw serialisation for Integer (GHC only)------- TODO  This instance is not architecture portable.  GMP stores numbers as--- arrays of machine sized words, so the byte format is not portable across--- architectures with different endianness and word size.--import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)-import GHC.Base     hiding (ord, chr)-import GHC.Prim-import GHC.Ptr (Ptr(..))-import GHC.IOBase (IO(..))--instance Binary Integer where-    put (S# i)    = putWord8 0 *> put (I# i)-    put (J# s ba) = do-        putWord8 1-        put (I# s)-        put (BA ba)--    get = do-        b <- getWord8-        case b of-            0 -> do (I# i#) <- get-                    return (S# i#)-            _ -> do (I# s#) <- get-                    (BA a#) <- get-                    return (J# s# a#)--instance Binary ByteArray where--    -- Pretty safe.-    put (BA ba) =-        let sz   = sizeofByteArray# ba   -- (primitive) in *bytes*-            addr = byteArrayContents# ba-            bs   = unsafePackAddress (I# sz) addr-        in put bs   -- write as a ByteString. easy, yay!--    -- Pretty scary. Should be quick though-    get = do-        (fp, off, n@(I# sz)) <- fmap toForeignPtr get      -- so decode a ByteString-        assert (off == 0) $ return $ unsafePerformIO $ do-            (MBA arr) <- newByteArray sz                    -- and copy it into a ByteArray#-            let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?-            withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)-            freezeByteArray arr---- wrapper for ByteArray#-data ByteArray = BA  {-# UNPACK #-} !ByteArray#-data MBA       = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)--newByteArray :: Int# -> IO MBA-newByteArray sz = IO $ \s ->-  case newPinnedByteArray# sz s of { (# s', arr #) ->-  (# s', MBA arr #) }--freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray-freezeByteArray arr = IO $ \s ->-  case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->-  (# s', BA arr' #) }---}--instance (Binary a,Integral a) => Binary (R.Ratio a) where-    put r = put (R.numerator r) *> put (R.denominator r)-    get = (R.%) <$> get <*> get------------------------------------------------------------------------------ Char is serialised as UTF-8-instance Binary Char where-    put a | c <= 0x7f     = put (fromIntegral c :: Word8)-          | c <= 0x7ff    = do put (0xc0 .|. y)-                               put (0x80 .|. z)-          | c <= 0xffff   = do put (0xe0 .|. x)-                               put (0x80 .|. y)-                               put (0x80 .|. z)-          | c <= 0x10ffff = do put (0xf0 .|. w)-                               put (0x80 .|. x)-                               put (0x80 .|. y)-                               put (0x80 .|. z)-          | otherwise     = error "Not a valid Unicode code point"-     where-        c = ord a-        z, y, x, w :: Word8-        z = fromIntegral (c           .&. 0x3f)-        y = fromIntegral (shiftR c 6  .&. 0x3f)-        x = fromIntegral (shiftR c 12 .&. 0x3f)-        w = fromIntegral (shiftR c 18 .&. 0x7)--    get = do-        let getByte = fmap (fromIntegral :: Word8 -> Int) get-            shiftL6 = flip shiftL 6 :: Int -> Int-        w <- getByte-        r <- case () of-                _ | w < 0x80  -> return w-                  | w < 0xe0  -> do-                                    x <- fmap (xor 0x80) getByte-                                    return (x .|. shiftL6 (xor 0xc0 w))-                  | w < 0xf0  -> do-                                    x <- fmap (xor 0x80) getByte-                                    y <- fmap (xor 0x80) getByte-                                    return (y .|. shiftL6 (x .|. shiftL6-                                            (xor 0xe0 w)))-                  | otherwise -> do-                                x <- fmap (xor 0x80) getByte-                                y <- fmap (xor 0x80) getByte-                                z <- fmap (xor 0x80) getByte-                                return (z .|. shiftL6 (y .|. shiftL6-                                        (x .|. shiftL6 (xor 0xf0 w))))-        return $! chr r----------------------------------------------------------------------------- Instances for the first few tuples--instance (Binary a, Binary b) => Binary (a,b) where-    put (a,b)           = put a *> put b-    get                 = (,) <$> get <*> get--instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where-    put (a,b,c)         = put a *> put b *> put c-    get                 = (,,) <$> get <*> get <*> get--instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where-    put (a,b,c,d)       = put a *> put b *> put c *> put d-    get                 = (,,,) <$> get <*> get <*> get <*> get--instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where-    put (a,b,c,d,e)     = put a *> put b *> put c *> put d *> put e-    get                 = (,,,,) <$> get <*> get <*> get <*> get <*> get------- and now just recurse:-----instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)-        => Binary (a,b,c,d,e,f) where-    put (a,b,c,d,e,f)   = put (a,(b,c,d,e,f))-    get                 = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)--instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)-        => Binary (a,b,c,d,e,f,g) where-    put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))-    get                 = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)--instance (Binary a, Binary b, Binary c, Binary d, Binary e,-          Binary f, Binary g, Binary h)-        => Binary (a,b,c,d,e,f,g,h) where-    put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))-    get                   = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)--instance (Binary a, Binary b, Binary c, Binary d, Binary e,-          Binary f, Binary g, Binary h, Binary i)-        => Binary (a,b,c,d,e,f,g,h,i) where-    put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))-    get                     = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)--instance (Binary a, Binary b, Binary c, Binary d, Binary e,-          Binary f, Binary g, Binary h, Binary i, Binary j)-        => Binary (a,b,c,d,e,f,g,h,i,j) where-    put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))-    get                       = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)----------------------------------------------------------------------------- Container types--instance Binary a => Binary [a] where-    put l  = put (length l) *> traverse_ put l-    get    = do n <- get :: Get Int-                getMany n---- | 'getMany n' get 'n' elements in order, without blowing the stack.-getMany :: Binary a => Int -> Get [a]-getMany n = go [] n- where-    go xs 0 = return $! reverse xs-    go xs i = do x <- get-                 -- we must seq x to avoid stack overflows due to laziness in-                 -- (>>=)-                 x `seq` go (x:xs) (i-1)-{-# INLINE getMany #-}--instance (Binary a) => Binary (Maybe a) where-    put Nothing  = putWord8 0-    put (Just x) = putWord8 1 *> put x-    get = do-        w <- getWord8-        case w of-            0 -> return Nothing-            _ -> fmap Just get--instance (Binary a, Binary b) => Binary (Either a b) where-    put (Left  a) = putWord8 0 *> put a-    put (Right b) = putWord8 1 *> put b-    get = do-        w <- getWord8-        case w of-            0 -> fmap Left  get-            _ -> fmap Right get----------------------------------------------------------------------------- ByteStrings (have specially efficient instances)--instance Binary B.ByteString where-    put bs = do put (B.length bs)-                putByteString bs-    get    = get >>= getByteString------- Using old versions of fps, this is a type synonym, and non portable------ Requires 'flexible instances'----instance Binary ByteString where-    put bs = do put (fromIntegral (L.length bs) :: Int)-                putLazyByteString bs-    get    = get >>= getLazyByteString----------------------------------------------------------------------------- Maps and Sets--instance (Binary a) => Binary (Set.Set a) where-    put s = put (Set.size s) *> traverse_ put (Set.toAscList s)-    get   = fmap Set.fromDistinctAscList get--instance (Binary k, Binary e) => Binary (Map.Map k e) where-    put m = put (Map.size m) *> traverse_ put (Map.toAscList m)-    get   = fmap Map.fromDistinctAscList get--instance Binary IntSet.IntSet where-    put s = put (IntSet.size s) *> traverse_ put (IntSet.toAscList s)-    get   = fmap IntSet.fromDistinctAscList get--instance (Binary e) => Binary (IntMap.IntMap e) where-    put m = put (IntMap.size m) *> traverse_ put (IntMap.toAscList m)-    get   = fmap IntMap.fromDistinctAscList get----------------------------------------------------------------------------- Queues and Sequences--instance (Binary e) => Binary (Seq.Seq e) where-    put s = put (Seq.length s) *> Fold.traverse_ put s-    get = do n <- get :: Get Int-             rep Seq.empty n get-      where rep xs 0 _ = return $! xs-            rep xs n g = xs `seq` n `seq` do-                           x <- g-                           rep (xs Seq.|> x) (n-1) g----------------------------------------------------------------------------- Floating point--instance Binary Double where-    put d = put (decodeFloat d)-    get   = encodeFloat <$> get <*> get--instance Binary Float where-    put f = put (decodeFloat f)-    get   = encodeFloat <$> get <*> get----------------------------------------------------------------------------- Trees--instance (Binary e) => Binary (T.Tree e) where-    put (T.Node r s) = put r *> put s-    get = T.Node <$> get <*> get----------------------------------------------------------------------------- Arrays--instance (Binary i, Ix i, Binary e) => Binary (Array i e) where-    put a = do-        put (bounds a)-        put (rangeSize $ bounds a) -- write the length-        traverse_ put (elems a)        -- now the elems.-    get = do-        bs <- get-        n  <- get                  -- read the length-        xs <- getMany n            -- now the elems.-        return (listArray bs xs)------- The IArray UArray e constraint is non portable. Requires flexible instances----instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where-    put a = do-        put (bounds a)-        put (rangeSize $ bounds a) -- now write the length-        traverse_ put (elems a)-    get = do-        bs <- get-        n  <- get-        xs <- getMany n-        return (listArray bs xs)
− src/Distribution/Compat/Binary/Generic.hs 
@@ -1,128 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures,-    ScopedTypeVariables, Trustworthy, TypeOperators, TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---------------------------------------------------------------------------------- |--- Module      : Distribution.Compat.Binary.Generic--- Copyright   : Bryan O'Sullivan--- License     : BSD3-style (see LICENSE)------ Maintainer  : Bryan O'Sullivan <bos@serpentine.com>--- Stability   : unstable--- Portability : Only works with GHC 7.2 and newer------ Instances for supporting GHC generics.----------------------------------------------------------------------------------module Distribution.Compat.Binary.Generic-    (-    ) where--import Control.Applicative-import Distribution.Compat.Binary.Class-import Data.Binary.Get-import Data.Binary.Put-import Data.Bits-import Data.Word-import GHC.Generics---- Type without constructors-instance GBinary V1 where-    gput _ = return ()-    gget   = return undefined---- Constructor without arguments-instance GBinary U1 where-    gput U1 = return ()-    gget    = return U1---- Product: constructor with parameters-instance (GBinary a, GBinary b) => GBinary (a :*: b) where-    gput (x :*: y) = gput x >> gput y-    gget = (:*:) <$> gget <*> gget---- Metadata (constructor name, etc)-instance GBinary a => GBinary (M1 i c a) where-    gput = gput . unM1-    gget = M1 <$> gget---- Constants, additional parameters, and rank-1 recursion-instance Binary a => GBinary (K1 i a) where-    gput = put . unK1-    gget = K1 <$> get---- Borrowed from the cereal package.---- The following GBinary instance for sums has support for serializing--- types with up to 2^64-1 constructors. It will use the minimal--- number of bytes needed to encode the constructor. For example when--- a type has 2^8 constructors or less it will use a single byte to--- encode the constructor. If it has 2^16 constructors or less it will--- use two bytes, and so on till 2^64-1.--#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)-#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)-#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)--instance ( GSum     a, GSum     b-         , GBinary a, GBinary b-         , SumSize    a, SumSize    b) => GBinary (a :+: b) where-    gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)-         | otherwise = sizeError "encode" size-      where-        size = unTagged (sumSize :: Tagged (a :+: b) Word64)--    gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64)-         | otherwise = sizeError "decode" size-      where-        size = unTagged (sumSize :: Tagged (a :+: b) Word64)--sizeError :: Show size => String -> size -> error-sizeError s size =-    error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors"----------------------------------------------------------------------------checkGetSum :: (Ord word, Num word, Bits word, GSum f)-            => word -> word -> Get (f a)-checkGetSum size code | code < size = getSum code size-                      | otherwise   = fail "Unknown encoding for constructor"-{-# INLINE checkGetSum #-}--class GSum f where-    getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)-    putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put--instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where-    getSum !code !size | code < sizeL = L1 <$> getSum code           sizeL-                       | otherwise    = R1 <$> getSum (code - sizeL) sizeR-        where-          sizeL = size `shiftR` 1-          sizeR = size - sizeL--    putSum !code !size s = case s of-                             L1 x -> putSum code           sizeL x-                             R1 x -> putSum (code + sizeL) sizeR x-        where-          sizeL = size `shiftR` 1-          sizeR = size - sizeL--instance GBinary a => GSum (C1 c a) where-    getSum _ _ = gget--    putSum !code _ x = put code *> gput x----------------------------------------------------------------------------class SumSize f where-    sumSize :: Tagged f Word64--newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}--instance (SumSize a, SumSize b) => SumSize (a :+: b) where-    sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) +-                       unTagged (sumSize :: Tagged b Word64)--instance SumSize (C1 c a) where-    sumSize = Tagged 1
− src/Distribution/Compat/CharParsing.hs 
@@ -1,357 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Compat.CharParsing--- Copyright   :  (c) Edward Kmett 2011--- License     :  BSD3------ Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  non-portable------ Parsers for character streams------ Originally in @parsers@ package.----------------------------------------------------------------------------------module Distribution.Compat.CharParsing-  (-  -- * Combinators-    oneOf        -- :: CharParsing m => [Char] -> m Char-  , noneOf       -- :: CharParsing m => [Char] -> m Char-  , spaces       -- :: CharParsing m => m ()-  , space        -- :: CharParsing m => m Char-  , newline      -- :: CharParsing m => m Char-  , tab          -- :: CharParsing m => m Char-  , upper        -- :: CharParsing m => m Char-  , lower        -- :: CharParsing m => m Char-  , alphaNum     -- :: CharParsing m => m Char-  , letter       -- :: CharParsing m => m Char-  , digit        -- :: CharParsing m => m Char-  , hexDigit     -- :: CharParsing m => m Char-  , octDigit     -- :: CharParsing m => m Char-  , satisfyRange -- :: CharParsing m => Char -> Char -> m Char-  -- * Class-  , CharParsing(..)-  -- * Cabal additions-  , integral-  , signedIntegral-  , munch1-  , munch-  , skipSpaces1-  , module Distribution.Compat.Parsing-  ) where--import Prelude ()-import Distribution.Compat.Prelude--import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.State.Lazy as Lazy-import Control.Monad.Trans.State.Strict as Strict-import Control.Monad.Trans.Writer.Lazy as Lazy-import Control.Monad.Trans.Writer.Strict as Strict-import Control.Monad.Trans.RWS.Lazy as Lazy-import Control.Monad.Trans.RWS.Strict as Strict-import Control.Monad.Trans.Reader (ReaderT (..))-import Control.Monad.Trans.Identity (IdentityT (..))-import Data.Char-import Data.Text (Text, unpack)--import qualified Text.Parsec as Parsec--import Distribution.Compat.Parsing---- | @oneOf cs@ succeeds if the current character is in the supplied--- list of characters @cs@. Returns the parsed character. See also--- 'satisfy'.------ >   vowel  = oneOf "aeiou"-oneOf :: CharParsing m => [Char] -> m Char-oneOf xs = satisfy (\c -> c `elem` xs)-{-# INLINE oneOf #-}---- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current--- character is /not/ in the supplied list of characters @cs@. Returns the--- parsed character.------ >  consonant = noneOf "aeiou"-noneOf :: CharParsing m => [Char] -> m Char-noneOf xs = satisfy (\c -> c `notElem` xs)-{-# INLINE noneOf #-}---- | Skips /zero/ or more white space characters. See also 'skipMany'.-spaces :: CharParsing m => m ()-spaces = skipMany space <?> "white space"-{-# INLINE spaces #-}---- | Parses a white space character (any character which satisfies 'isSpace')--- Returns the parsed character.-space :: CharParsing m => m Char-space = satisfy isSpace <?> "space"-{-# INLINE space #-}---- | Parses a newline character (\'\\n\'). Returns a newline character.-newline :: CharParsing m => m Char-newline = char '\n' <?> "new-line"-{-# INLINE newline #-}---- | Parses a tab character (\'\\t\'). Returns a tab character.-tab :: CharParsing m => m Char-tab = char '\t' <?> "tab"-{-# INLINE tab #-}---- | Parses an upper case letter. Returns the parsed character.-upper :: CharParsing m => m Char-upper = satisfy isUpper <?> "uppercase letter"-{-# INLINE upper #-}---- | Parses a lower case character. Returns the parsed character.-lower :: CharParsing m => m Char-lower = satisfy isLower <?> "lowercase letter"-{-# INLINE lower #-}---- | Parses a letter or digit. Returns the parsed character.-alphaNum :: CharParsing m => m Char-alphaNum = satisfy isAlphaNum <?> "letter or digit"-{-# INLINE alphaNum #-}---- | Parses a letter (an upper case or lower case character). Returns the--- parsed character.-letter :: CharParsing m => m Char-letter = satisfy isAlpha <?> "letter"-{-# INLINE letter #-}---- | Parses a digit. Returns the parsed character.-digit :: CharParsing m => m Char-digit = satisfy isDigit <?> "digit"-{-# INLINE digit #-}---- | Parses a hexadecimal digit (a digit or a letter between \'a\' and--- \'f\' or \'A\' and \'F\'). Returns the parsed character.-hexDigit :: CharParsing m => m Char-hexDigit = satisfy isHexDigit <?> "hexadecimal digit"-{-# INLINE hexDigit #-}---- | Parses an octal digit (a character between \'0\' and \'7\'). Returns--- the parsed character.-octDigit :: CharParsing m => m Char-octDigit = satisfy isOctDigit <?> "octal digit"-{-# INLINE octDigit #-}--satisfyRange :: CharParsing m => Char -> Char -> m Char-satisfyRange a z = satisfy (\c -> c >= a && c <= z)-{-# INLINE satisfyRange #-}---- | Additional functionality needed to parse character streams.-class Parsing m => CharParsing m where-  -- | Parse a single character of the input, with UTF-8 decoding-  satisfy :: (Char -> Bool) -> m Char--  -- | @char c@ parses a single character @c@. Returns the parsed-  -- character (i.e. @c@).-  ---  -- /e.g./-  ---  -- @semiColon = 'char' ';'@-  char :: Char -> m Char-  char c = satisfy (c ==) <?> show [c]-  {-# INLINE char #-}--  -- | @notChar c@ parses any single character other than @c@. Returns the parsed-  -- character.-  notChar :: Char -> m Char-  notChar c = satisfy (c /=)-  {-# INLINE notChar #-}--  -- | This parser succeeds for any character. Returns the parsed character.-  anyChar :: m Char-  anyChar = satisfy (const True)-  {-# INLINE anyChar #-}--  -- | @string s@ parses a sequence of characters given by @s@. Returns-  -- the parsed string (i.e. @s@).-  ---  -- >  divOrMod    =   string "div"-  -- >              <|> string "mod"-  string :: String -> m String-  string s = s <$ try (traverse_ char s) <?> show s-  {-# INLINE string #-}--  -- | @text t@ parses a sequence of characters determined by the text @t@ Returns-  -- the parsed text fragment (i.e. @t@).-  ---  -- Using @OverloadedStrings@:-  ---  -- >  divOrMod    =   text "div"-  -- >              <|> text "mod"-  text :: Text -> m Text-  text t = t <$ string (unpack t)-  {-# INLINE text #-}--instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where-  satisfy = lift . satisfy-  {-# INLINE satisfy #-}-  char    = lift . char-  {-# INLINE char #-}-  notChar = lift . notChar-  {-# INLINE notChar #-}-  anyChar = lift anyChar-  {-# INLINE anyChar #-}-  string  = lift . string-  {-# INLINE string #-}-  text = lift . text-  {-# INLINE text #-}--instance (CharParsing m, MonadPlus m) => CharParsing (Strict.StateT s m) where-  satisfy = lift . satisfy-  {-# INLINE satisfy #-}-  char    = lift . char-  {-# INLINE char #-}-  notChar = lift . notChar-  {-# INLINE notChar #-}-  anyChar = lift anyChar-  {-# INLINE anyChar #-}-  string  = lift . string-  {-# INLINE string #-}-  text = lift . text-  {-# INLINE text #-}--instance (CharParsing m, MonadPlus m) => CharParsing (ReaderT e m) where-  satisfy = lift . satisfy-  {-# INLINE satisfy #-}-  char    = lift . char-  {-# INLINE char #-}-  notChar = lift . notChar-  {-# INLINE notChar #-}-  anyChar = lift anyChar-  {-# INLINE anyChar #-}-  string  = lift . string-  {-# INLINE string #-}-  text = lift . text-  {-# INLINE text #-}--instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.WriterT w m) where-  satisfy = lift . satisfy-  {-# INLINE satisfy #-}-  char    = lift . char-  {-# INLINE char #-}-  notChar = lift . notChar-  {-# INLINE notChar #-}-  anyChar = lift anyChar-  {-# INLINE anyChar #-}-  string  = lift . string-  {-# INLINE string #-}-  text = lift . text-  {-# INLINE text #-}--instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.WriterT w m) where-  satisfy = lift . satisfy-  {-# INLINE satisfy #-}-  char    = lift . char-  {-# INLINE char #-}-  notChar = lift . notChar-  {-# INLINE notChar #-}-  anyChar = lift anyChar-  {-# INLINE anyChar #-}-  string  = lift . string-  {-# INLINE string #-}-  text = lift . text-  {-# INLINE text #-}--instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.RWST r w s m) where-  satisfy = lift . satisfy-  {-# INLINE satisfy #-}-  char    = lift . char-  {-# INLINE char #-}-  notChar = lift . notChar-  {-# INLINE notChar #-}-  anyChar = lift anyChar-  {-# INLINE anyChar #-}-  string  = lift . string-  {-# INLINE string #-}-  text = lift . text-  {-# INLINE text #-}--instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.RWST r w s m) where-  satisfy = lift . satisfy-  {-# INLINE satisfy #-}-  char    = lift . char-  {-# INLINE char #-}-  notChar = lift . notChar-  {-# INLINE notChar #-}-  anyChar = lift anyChar-  {-# INLINE anyChar #-}-  string  = lift . string-  {-# INLINE string #-}-  text = lift . text-  {-# INLINE text #-}--instance (CharParsing m, MonadPlus m) => CharParsing (IdentityT m) where-  satisfy = lift . satisfy-  {-# INLINE satisfy #-}-  char    = lift . char-  {-# INLINE char #-}-  notChar = lift . notChar-  {-# INLINE notChar #-}-  anyChar = lift anyChar-  {-# INLINE anyChar #-}-  string  = lift . string-  {-# INLINE string #-}-  text = lift . text-  {-# INLINE text #-}--instance Parsec.Stream s m Char => CharParsing (Parsec.ParsecT s u m) where-  satisfy   = Parsec.satisfy-  char      = Parsec.char-  notChar c = Parsec.satisfy (/= c)-  anyChar   = Parsec.anyChar-  string    = Parsec.string------------------------------------------------------------------------------------ Our additions----------------------------------------------------------------------------------integral :: (CharParsing m, Integral a) => m a-integral = toNumber <$> some d <?> "integral"-  where-    toNumber = foldl' (\a b -> a * 10 + b) 0-    d = f <$> satisfyRange '0' '9'-    f '0' = 0-    f '1' = 1-    f '2' = 2-    f '3' = 3-    f '4' = 4-    f '5' = 5-    f '6' = 6-    f '7' = 7-    f '8' = 8-    f '9' = 9-    f _   = error "panic! integral"-{-# INLINE integral #-}---- | Accepts negative (starting with @-@) and positive (without sign) integral--- numbers.--- --- @since 3.4.0.0-signedIntegral :: (CharParsing m, Integral a) => m a-signedIntegral = negate <$ char '-' <*> integral <|> integral-{-# INLINE signedIntegral #-}---- | Greedily munch characters while predicate holds.--- Require at least one character.-munch1 :: CharParsing m => (Char -> Bool) -> m String-munch1 = some . satisfy-{-# INLINE munch1 #-}---- | Greedely munch characters while predicate holds.--- Always succeeds.-munch :: CharParsing m => (Char -> Bool) -> m String-munch = many . satisfy-{-# INLINE munch #-}--skipSpaces1 :: CharParsing m => m ()-skipSpaces1 = skipSome space-{-# INLINE skipSpaces1 #-}
src/Distribution/Compat/CopyFile.hs view
@@ -1,18 +1,19 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-}-module Distribution.Compat.CopyFile (-  copyFile,-  copyFileChanged,-  filesEqual,-  copyOrdinaryFile,-  copyExecutableFile,-  setFileOrdinary,-  setFileExecutable,-  setDirOrdinary,++module Distribution.Compat.CopyFile+  ( copyFile+  , copyFileChanged+  , filesEqual+  , copyOrdinaryFile+  , copyExecutableFile+  , setFileOrdinary+  , setFileExecutable+  , setDirOrdinary   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  #ifndef mingw32_HOST_OS import Distribution.Compat.Internal.TempFile@@ -20,6 +21,8 @@ import Control.Exception          ( bracketOnError ) import qualified Data.ByteString.Lazy as BSL+import Data.Bits+         ( (.|.) ) import System.IO.Error          ( ioeSetLocation ) import System.Directory@@ -34,10 +37,8 @@  import System.Posix.Types          ( FileMode )-import System.Posix.Internals-         ( c_chmod, withFilePath )-import Foreign.C-         ( throwErrnoPathIfMinus1_ )+import System.Posix.Files+         ( getFileStatus, fileMode, setFileMode )  #else /* else mingw32_HOST_OS */ @@ -66,18 +67,20 @@ #endif /* mingw32_HOST_OS */  copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()-copyOrdinaryFile   src dest = copyFile src dest >> setFileOrdinary   dest+copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest -setFileOrdinary,  setFileExecutable, setDirOrdinary  :: FilePath -> IO ()+setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () #ifndef mingw32_HOST_OS-setFileOrdinary   path = setFileMode path 0o644 -- file perms -rw-r--r---setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x+-- When running with a restrictive UMASK such as 0077 we still want to+-- install files and directories that are accessible to other users.+setFileOrdinary   path = addFileMode path 0o644 -- file perms -rw-r--r--+setFileExecutable path = addFileMode path 0o755 -- file perms -rwxr-xr-x -setFileMode :: FilePath -> FileMode -> IO ()-setFileMode name m =-  withFilePath name $ \s -> do-    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)+addFileMode :: FilePath -> FileMode -> IO ()+addFileMode name m = do+  o <- fileMode <$> getFileStatus name+  setFileMode name (m .|. o) #else setFileOrdinary   _ = return () setFileExecutable _ = return ()@@ -91,7 +94,7 @@ copyFile fromFPath toFPath =   copy     `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile"))-    where+  where #ifndef mingw32_HOST_OS       copy = withBinaryFile fromFPath ReadMode $ \hFrom ->              bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->@@ -237,8 +240,9 @@ filesEqual f1 f2 = do   ex1 <- doesFileExist f1   ex2 <- doesFileExist f2-  if not (ex1 && ex2) then return False else-    withBinaryFile f1 ReadMode $ \h1 ->+  if not (ex1 && ex2)+    then return False+    else withBinaryFile f1 ReadMode $ \h1 ->       withBinaryFile f2 ReadMode $ \h2 -> do         s1 <- hFileSize h1         s2 <- hFileSize h2
src/Distribution/Compat/CreatePipe.hs view
@@ -1,81 +1,5 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}--module Distribution.Compat.CreatePipe (createPipe) where+module Distribution.Compat.CreatePipe+  {-# DEPRECATED "Use System.Process from package process directly" #-}+  (createPipe) where -#if MIN_VERSION_process(1,2,1) import System.Process (createPipe)-#else-import System.IO (Handle, hSetBinaryMode)--import Prelude ()-import Distribution.Compat.Prelude-import Distribution.Compat.Stack---- The mingw32_HOST_OS CPP macro is GHC-specific-#ifdef mingw32_HOST_OS-import qualified Prelude-import Control.Exception (onException)-import Foreign.C.Error (throwErrnoIfMinus1_)-import Foreign.C.Types (CInt(..), CUInt(..))-import Foreign.Ptr (Ptr)-import Foreign.Marshal.Array (allocaArray)-import Foreign.Storable (peek, peekElemOff)-import GHC.IO.FD (mkFD)-import GHC.IO.Device (IODeviceType(Stream))-import GHC.IO.Handle.FD (mkHandleFromFD)-import System.IO (IOMode(ReadMode, WriteMode))-#elif defined ghcjs_HOST_OS-#else-import System.Posix.IO (fdToHandle)-import qualified System.Posix.IO as Posix-#endif--createPipe :: IO (Handle, Handle)--- The mingw32_HOST_OS CPP macro is GHC-specific-#ifdef mingw32_HOST_OS-createPipe = do-    (readfd, writefd) <- allocaArray 2 $ \ pfds -> do-        throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 ({- _O_BINARY -} 32768)-        readfd <- peek pfds-        writefd <- peekElemOff pfds 1-        return (readfd, writefd)-    (do readh <- fdToHandle readfd ReadMode-        writeh <- fdToHandle writefd WriteMode-        hSetBinaryMode readh True-        hSetBinaryMode writeh True-        return (readh, writeh)) `onException` (close readfd >> close writefd)-  where-    fdToHandle :: CInt -> IOMode -> IO Handle-    fdToHandle fd mode = do-        (fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False-        mkHandleFromFD fd' deviceType "" mode False Nothing--    close :: CInt -> IO ()-    close = throwErrnoIfMinus1_ "_close" . c__close-      where _ = callStack -- TODO: attach call stack to exception--    _ = callStack -- TODO: attach call stack to exceptions--foreign import ccall "io.h _pipe" c__pipe ::-    Ptr CInt -> CUInt -> CInt -> Prelude.IO CInt--foreign import ccall "io.h _close" c__close ::-    CInt -> Prelude.IO CInt-#elif defined ghcjs_HOST_OS-createPipe = error "createPipe"-  where-    _ = callStack-#else-createPipe = do-    (readfd, writefd) <- Posix.createPipe-    readh <- fdToHandle readfd-    writeh <- fdToHandle writefd-    hSetBinaryMode readh True-    hSetBinaryMode writeh True-    return (readh, writeh)-  where-    _ = callStack-#endif-#endif
− src/Distribution/Compat/DList.hs 
@@ -1,53 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Compat.DList--- Copyright   :  (c) Ben Gamari 2015-2019--- License     :  BSD3------ Maintainer  :  cabal-dev@haskell.org--- Stability   :  experimental--- Portability :  portable------ A very simple difference list.-module Distribution.Compat.DList (-    DList,-    runDList,-    empty,-    singleton,-    fromList,-    toList,-    snoc,-) where--import Prelude ()-import Distribution.Compat.Prelude hiding (toList, empty)---- | Difference list.-newtype DList a = DList ([a] -> [a])--runDList :: DList a -> [a]-runDList (DList run) = run []---- | Make 'DList' containing single element.-singleton :: a -> DList a-singleton a = DList (a:)---- | @since 3.4.0.0-empty :: DList a-empty = DList id--fromList :: [a] -> DList a-fromList as = DList (as ++)--toList :: DList a -> [a]-toList = runDList--snoc :: DList a -> a -> DList a-snoc xs x = xs <> singleton x--instance Monoid (DList a) where-  mempty  = empty-  mappend = (<>)--instance Semigroup (DList a) where-  DList a <> DList b = DList (a . b)
src/Distribution/Compat/Directory.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-}  module Distribution.Compat.Directory-( listDirectory-, makeAbsolute-, doesPathExist-) where+  ( listDirectory+  , makeAbsolute+  , doesPathExist+  ) where  #if MIN_VERSION_directory(1,2,7) import System.Directory as Dir hiding (doesPathExist)@@ -46,4 +46,3 @@     else doesFileExist path  #endif-
src/Distribution/Compat/Environment.hs view
@@ -3,33 +3,20 @@ {-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.Environment-       ( getEnvironment, lookupEnv, setEnv, unsetEnv )-       where+module Distribution.Compat.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv)+where +import Distribution.Compat.Prelude import Prelude () import qualified Prelude-import Distribution.Compat.Prelude -#ifndef mingw32_HOST_OS-#if __GLASGOW_HASKELL__ < 708-import Foreign.C.Error (throwErrnoIf_)-#endif-#endif-+import System.Environment (lookupEnv, unsetEnv) import qualified System.Environment as System-import System.Environment (lookupEnv)-#if __GLASGOW_HASKELL__ >= 708-import System.Environment (unsetEnv)-#endif  import Distribution.Compat.Stack  #ifdef mingw32_HOST_OS import Foreign.C-#if __GLASGOW_HASKELL__ < 708-import Foreign.Ptr (nullPtr)-#endif import GHC.Windows #else import Foreign.C.Types@@ -73,9 +60,10 @@  where   _ = callStack -- TODO: attach CallStack to exception +{- FOURMOLU_DISABLE -} # if defined(i386_HOST_ARCH) #  define WINDOWS_CCONV stdcall-# elif defined(x86_64_HOST_ARCH)+# elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) #  define WINDOWS_CCONV ccall # else #  error Unknown mingw32 arch@@ -95,40 +83,4 @@ foreign import ccall unsafe "setenv"    c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt #endif /* mingw32_HOST_OS */--#if __GLASGOW_HASKELL__ < 708---- | @unsetEnv name@ removes the specified environment variable from the--- environment of the current process.------ Throws `Control.Exception.IOException` if @name@ is the empty string or--- contains an equals sign.------ @since 4.7.0.0-unsetEnv :: String -> IO ()-#ifdef mingw32_HOST_OS-unsetEnv key = withCWString key $ \k -> do-  success <- c_SetEnvironmentVariable k nullPtr-  unless success $ do-    -- We consider unsetting an environment variable that does not exist not as-    -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND.-    err <- c_GetLastError-    unless (err == eRROR_ENVVAR_NOT_FOUND) $ do-      throwGetLastError "unsetEnv"--eRROR_ENVVAR_NOT_FOUND :: DWORD-eRROR_ENVVAR_NOT_FOUND = 203--foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"-    c_GetLastError:: IO DWORD-#else-unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)-#if __GLASGOW_HASKELL__ > 706-foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> Prelude.IO CInt-#else--- HACK: We hope very hard that !UNSETENV_RETURNS_VOID-foreign import ccall unsafe "unsetenv" c_unsetenv :: CString -> Prelude.IO CInt-#endif-#endif--#endif+{- FOURMOLU_ENABLE -}
− src/Distribution/Compat/Exception.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE CPP #-}-module Distribution.Compat.Exception (-  catchIO,-  catchExit,-  tryIO,-  displayException,-  ) where--#ifdef MIN_VERSION_base-#define MINVER_base_48 MIN_VERSION_base(4,8,0)-#else-#define MINVER_base_48 (__GLASGOW_HASKELL__ >= 710)-#endif--import System.Exit-import qualified Control.Exception as Exception--#if MINVER_base_48-import Control.Exception (displayException)-#endif---- | Try 'IOException'.-tryIO :: IO a -> IO (Either Exception.IOException a)-tryIO = Exception.try---- | Catch 'IOException'.-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-catchIO = Exception.catch---- | Catch 'ExitCode'-catchExit :: IO a -> (ExitCode -> IO a) -> IO a-catchExit = Exception.catch--#if !MINVER_base_48-displayException :: Exception.Exception e => e -> String-displayException = show-#endif
src/Distribution/Compat/FilePath.hs view
@@ -1,13 +1,12 @@ {-# LANGUAGE CPP #-}--{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}  module Distribution.Compat.FilePath-( isExtensionOf-, stripExtension-) where+  ( isExtensionOf+  , stripExtension+  ) where -import Data.List ( isSuffixOf, stripPrefix )+import Data.List (isSuffixOf, stripPrefix) import System.FilePath  #if !MIN_VERSION_filepath(1,4,2)
src/Distribution/Compat/GetShortPathName.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Compat.GetShortPathName --@@ -8,12 +9,11 @@ -- Portability :  Windows-only -- -- Win32 API 'GetShortPathName' function.--module Distribution.Compat.GetShortPathName ( getShortPathName )-    where+module Distribution.Compat.GetShortPathName (getShortPathName)+where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  #ifdef mingw32_HOST_OS @@ -22,7 +22,8 @@ import System.Win32          (LPCTSTR, LPTSTR, DWORD) import Foreign.Marshal.Array (allocaArray) -#ifdef x86_64_HOST_ARCH+{- FOURMOLU_DISABLE -}+#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) #define WINAPI ccall #else #define WINAPI stdcall@@ -57,3 +58,4 @@ getShortPathName path = return path  #endif+{- FOURMOLU_ENABLE -}
− src/Distribution/Compat/Graph.hs 
@@ -1,408 +0,0 @@-{-# LANGUAGE BangPatterns         #-}-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE DeriveDataTypeable   #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Compat.Graph--- Copyright   :  (c) Edward Z. Yang 2016--- License     :  BSD3------ Maintainer  :  cabal-dev@haskell.org--- Stability   :  experimental--- Portability :  portable------ A data type representing directed graphs, backed by "Data.Graph".--- It is strict in the node type.------ This is an alternative interface to "Data.Graph".  In this interface,--- nodes (identified by the 'IsNode' type class) are associated with a--- key and record the keys of their neighbors.  This interface is more--- convenient than 'Data.Graph.Graph', which requires vertices to be--- explicitly handled by integer indexes.------ The current implementation has somewhat peculiar performance--- characteristics.  The asymptotics of all map-like operations mirror--- their counterparts in "Data.Map".  However, to perform a graph--- operation, we first must build the "Data.Graph" representation, an--- operation that takes /O(V + E log V)/.  However, this operation can--- be amortized across all queries on that particular graph.------ Some nodes may be broken, i.e., refer to neighbors which are not--- stored in the graph.  In our graph algorithms, we transparently--- ignore such edges; however, you can easily query for the broken--- vertices of a graph using 'broken' (and should, e.g., to ensure that--- a closure of a graph is well-formed.)  It's possible to take a closed--- subset of a broken graph and get a well-formed graph.-----------------------------------------------------------------------------------module Distribution.Compat.Graph (-    -- * Graph type-    Graph,-    IsNode(..),-    -- * Query-    null,-    size,-    member,-    lookup,-    -- * Construction-    empty,-    insert,-    deleteKey,-    deleteLookup,-    -- * Combine-    unionLeft,-    unionRight,-    -- * Graph algorithms-    stronglyConnComp,-    SCC(..),-    cycles,-    broken,-    neighbors,-    revNeighbors,-    closure,-    revClosure,-    topSort,-    revTopSort,-    -- * Conversions-    -- ** Maps-    toMap,-    -- ** Lists-    fromDistinctList,-    toList,-    keys,-    -- ** Sets-    keysSet,-    -- ** Graphs-    toGraph,-    -- * Node type-    Node(..),-    nodeValue,-) where--import Distribution.Compat.Prelude hiding (empty, lookup, null, toList)-import Prelude ()--import Data.Array                    ((!))-import Data.Graph                    (SCC (..))-import Distribution.Utils.Structured (Structure (..), Structured (..))--import qualified Data.Array                  as Array-import qualified Data.Foldable               as Foldable-import qualified Data.Graph                  as G-import qualified Data.Map.Strict             as Map-import qualified Data.Set                    as Set-import qualified Data.Tree                   as Tree-import qualified Distribution.Compat.Prelude as Prelude---- | A graph of nodes @a@.  The nodes are expected to have instance--- of class 'IsNode'.-data Graph a-    = Graph {-        graphMap          :: !(Map (Key a) a),-        -- Lazily cached graph representation-        graphForward      :: G.Graph,-        graphAdjoint      :: G.Graph,-        graphVertexToNode :: G.Vertex -> a,-        graphKeyToVertex  :: Key a -> Maybe G.Vertex,-        graphBroken       :: [(a, [Key a])]-    }-    deriving (Typeable)---- NB: Not a Functor! (or Traversable), because you need--- to restrict Key a ~ Key b.  We provide our own mapping--- functions.---- General strategy is most operations are deferred to the--- Map representation.--instance Show a => Show (Graph a) where-    show = show . toList--instance (IsNode a, Read a, Show (Key a)) => Read (Graph a) where-    readsPrec d s = map (\(a,r) -> (fromDistinctList a, r)) (readsPrec d s)--instance (IsNode a, Binary a, Show (Key a)) => Binary (Graph a) where-    put x = put (toList x)-    get = fmap fromDistinctList get--instance Structured a => Structured (Graph a) where-    structure p = Nominal (typeRep p) 0 "Graph" [structure (Proxy :: Proxy a)]--instance (Eq (Key a), Eq a) => Eq (Graph a) where-    g1 == g2 = graphMap g1 == graphMap g2--instance Foldable.Foldable Graph where-    fold = Foldable.fold . graphMap-    foldr f z = Foldable.foldr f z . graphMap-    foldl f z = Foldable.foldl f z . graphMap-    foldMap f = Foldable.foldMap f . graphMap-    foldl' f z = Foldable.foldl' f z . graphMap-    foldr' f z = Foldable.foldr' f z . graphMap-#ifdef MIN_VERSION_base-#if MIN_VERSION_base(4,8,0)-    length = Foldable.length . graphMap-    null   = Foldable.null   . graphMap-    toList = Foldable.toList . graphMap-    elem x = Foldable.elem x . graphMap-    maximum = Foldable.maximum . graphMap-    minimum = Foldable.minimum . graphMap-    sum     = Foldable.sum     . graphMap-    product = Foldable.product . graphMap-#endif-#endif--instance (NFData a, NFData (Key a)) => NFData (Graph a) where-    rnf Graph {-        graphMap = m,-        graphForward = gf,-        graphAdjoint = ga,-        graphVertexToNode = vtn,-        graphKeyToVertex = ktv,-        graphBroken = b-    } = gf `seq` ga `seq` vtn `seq` ktv `seq` b `seq` rnf m---- TODO: Data instance?---- | The 'IsNode' class is used for datatypes which represent directed--- graph nodes.  A node of type @a@ is associated with some unique key of--- type @'Key' a@; given a node we can determine its key ('nodeKey')--- and the keys of its neighbors ('nodeNeighbors').-class Ord (Key a) => IsNode a where-    type Key a-    nodeKey :: a -> Key a-    nodeNeighbors :: a -> [Key a]--instance (IsNode a, IsNode b, Key a ~ Key b) => IsNode (Either a b) where-    type Key (Either a b) = Key a-    nodeKey (Left x)  = nodeKey x-    nodeKey (Right x) = nodeKey x-    nodeNeighbors (Left x)  = nodeNeighbors x-    nodeNeighbors (Right x) = nodeNeighbors x---- | A simple, trivial data type which admits an 'IsNode' instance.-data Node k a = N a k [k]-    deriving (Show, Eq)---- | Get the value from a 'Node'.-nodeValue :: Node k a -> a-nodeValue (N a _ _) = a--instance Functor (Node k) where-    fmap f (N a k ks) = N (f a) k ks--instance Ord k => IsNode (Node k a) where-    type Key (Node k a) = k-    nodeKey (N _ k _) = k-    nodeNeighbors (N _ _ ks) = ks---- TODO: Maybe introduce a typeclass for items which just--- keys (so, Key associated type, and nodeKey method).  But--- I didn't need it here, so I didn't introduce it.---- Query---- | /O(1)/. Is the graph empty?-null :: Graph a -> Bool-null = Map.null . toMap---- | /O(1)/. The number of nodes in the graph.-size :: Graph a -> Int-size = Map.size . toMap---- | /O(log V)/. Check if the key is in the graph.-member :: IsNode a => Key a -> Graph a -> Bool-member k g = Map.member k (toMap g)---- | /O(log V)/. Lookup the node at a key in the graph.-lookup :: IsNode a => Key a -> Graph a -> Maybe a-lookup k g = Map.lookup k (toMap g)---- Construction---- | /O(1)/. The empty graph.-empty :: IsNode a => Graph a-empty = fromMap Map.empty---- | /O(log V)/. Insert a node into a graph.-insert :: IsNode a => a -> Graph a -> Graph a-insert !n g = fromMap (Map.insert (nodeKey n) n (toMap g))---- | /O(log V)/. Delete the node at a key from the graph.-deleteKey :: IsNode a => Key a -> Graph a -> Graph a-deleteKey k g = fromMap (Map.delete k (toMap g))---- | /O(log V)/. Lookup and delete.  This function returns the deleted--- value if it existed.-deleteLookup :: IsNode a => Key a -> Graph a -> (Maybe a, Graph a)-deleteLookup k g =-    let (r, m') = Map.updateLookupWithKey (\_ _ -> Nothing) k (toMap g)-    in (r, fromMap m')---- Combining---- | /O(V + V')/. Right-biased union, preferring entries--- from the second map when conflicts occur.--- @'nodeKey' x = 'nodeKey' (f x)@.-unionRight :: IsNode a => Graph a -> Graph a -> Graph a-unionRight g g' = fromMap (Map.union (toMap g') (toMap g))---- | /O(V + V')/. Left-biased union, preferring entries from--- the first map when conflicts occur.-unionLeft :: IsNode a => Graph a -> Graph a -> Graph a-unionLeft = flip unionRight---- Graph-like operations---- | /Ω(V + E)/. Compute the strongly connected components of a graph.--- Requires amortized construction of graph.-stronglyConnComp :: Graph a -> [SCC a]-stronglyConnComp g = map decode forest-  where-    forest = G.scc (graphForward g)-    decode (Tree.Node v [])-        | mentions_itself v = CyclicSCC  [graphVertexToNode g v]-        | otherwise         = AcyclicSCC (graphVertexToNode g v)-    decode other = CyclicSCC (dec other [])-        where dec (Tree.Node v ts) vs-                = graphVertexToNode g v : foldr dec vs ts-    mentions_itself v = v `elem` (graphForward g ! v)--- Implementation copied from 'stronglyConnCompR' in 'Data.Graph'.---- | /Ω(V + E)/. Compute the cycles of a graph.--- Requires amortized construction of graph.-cycles :: Graph a -> [[a]]-cycles g = [ vs | CyclicSCC vs <- stronglyConnComp g ]---- | /O(1)/.  Return a list of nodes paired with their broken--- neighbors (i.e., neighbor keys which are not in the graph).--- Requires amortized construction of graph.-broken :: Graph a -> [(a, [Key a])]-broken g = graphBroken g---- | Lookup the immediate neighbors from a key in the graph.--- Requires amortized construction of graph.-neighbors :: Graph a -> Key a -> Maybe [a]-neighbors g k = do-    v <- graphKeyToVertex g k-    return (map (graphVertexToNode g) (graphForward g ! v))---- | Lookup the immediate reverse neighbors from a key in the graph.--- Requires amortized construction of graph.-revNeighbors :: Graph a -> Key a -> Maybe [a]-revNeighbors g k = do-    v <- graphKeyToVertex g k-    return (map (graphVertexToNode g) (graphAdjoint g ! v))---- | Compute the subgraph which is the closure of some set of keys.--- Returns @Nothing@ if one (or more) keys are not present in--- the graph.--- Requires amortized construction of graph.-closure :: Graph a -> [Key a] -> Maybe [a]-closure g ks = do-    vs <- traverse (graphKeyToVertex g) ks-    return (decodeVertexForest g (G.dfs (graphForward g) vs))---- | Compute the reverse closure of a graph from some set--- of keys.  Returns @Nothing@ if one (or more) keys are not present in--- the graph.--- Requires amortized construction of graph.-revClosure :: Graph a -> [Key a] -> Maybe [a]-revClosure g ks = do-    vs <- traverse (graphKeyToVertex g) ks-    return (decodeVertexForest g (G.dfs (graphAdjoint g) vs))--flattenForest :: Tree.Forest a -> [a]-flattenForest = concatMap Tree.flatten--decodeVertexForest :: Graph a -> Tree.Forest G.Vertex -> [a]-decodeVertexForest g = map (graphVertexToNode g) . flattenForest---- | Topologically sort the nodes of a graph.--- Requires amortized construction of graph.-topSort :: Graph a -> [a]-topSort g = map (graphVertexToNode g) $ G.topSort (graphForward g)---- | Reverse topologically sort the nodes of a graph.--- Requires amortized construction of graph.-revTopSort :: Graph a -> [a]-revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g)---- Conversions---- | /O(1)/. Convert a map from keys to nodes into a graph.--- The map must satisfy the invariant that--- @'fromMap' m == 'fromList' ('Data.Map.elems' m)@;--- if you can't fulfill this invariant use @'fromList' ('Data.Map.elems' m)@--- instead.  The values of the map are assumed to already--- be in WHNF.-fromMap :: IsNode a => Map (Key a) a -> Graph a-fromMap m-    = Graph { graphMap = m-            -- These are lazily computed!-            , graphForward = g-            , graphAdjoint = G.transposeG g-            , graphVertexToNode = vertex_to_node-            , graphKeyToVertex = key_to_vertex-            , graphBroken = broke-            }-  where-    try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k)--    (brokenEdges, edges)-        = unzip-        $ [ partitionEithers (map try_key_to_vertex (nodeNeighbors n))-          | n <- ns ]-    broke = filter (not . Prelude.null . snd) (zip ns brokenEdges)--    g = Array.listArray bounds edges--    ns              = Map.elems m -- sorted ascending-    vertices        = zip (map nodeKey ns) [0..]-    vertex_map      = Map.fromAscList vertices-    key_to_vertex k = Map.lookup k vertex_map--    vertex_to_node vertex = nodeTable ! vertex--    nodeTable   = Array.listArray bounds ns-    bounds = (0, Map.size m - 1)---- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph.-fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a-fromDistinctList = fromMap-                 . Map.fromListWith (\_ -> duplicateError)-                 . map (\n -> n `seq` (nodeKey n, n))-  where-    duplicateError n = error $ "Graph.fromDistinctList: duplicate key: "-                            ++ show (nodeKey n)---- Map-like operations---- | /O(V)/. Convert a graph into a list of nodes.-toList :: Graph a -> [a]-toList g = Map.elems (toMap g)---- | /O(V)/. Convert a graph into a list of keys.-keys :: Graph a -> [Key a]-keys g = Map.keys (toMap g)---- | /O(V)/. Convert a graph into a set of keys.-keysSet :: Graph a -> Set.Set (Key a)-keysSet g = Map.keysSet (toMap g)---- | /O(1)/. Convert a graph into a map from keys to nodes.--- The resulting map @m@ is guaranteed to have the property that--- @'Prelude.all' (\(k,n) -> k == 'nodeKey' n) ('Data.Map.toList' m)@.-toMap :: Graph a -> Map (Key a) a-toMap = graphMap---- Graph-like operations---- | /O(1)/. Convert a graph into a 'Data.Graph.Graph'.--- Requires amortized construction of graph.-toGraph :: Graph a -> (G.Graph, G.Vertex -> a, Key a -> Maybe G.Vertex)-toGraph g = (graphForward g, graphVertexToNode g, graphKeyToVertex g)
src/Distribution/Compat/Internal/TempFile.hs view
@@ -1,30 +1,20 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-}-module Distribution.Compat.Internal.TempFile (-  openTempFile,-  openBinaryTempFile,-  openNewBinaryFile,-  createTempDirectory,++module Distribution.Compat.Internal.TempFile+  ( openTempFile+  , openBinaryTempFile+  , openNewBinaryFile+  , createTempDirectory   ) where  import Distribution.Compat.Exception -import System.FilePath        ((</>))--import System.IO              (Handle, openTempFile, openBinaryTempFile)-#if defined(__IO_MANAGER_WINIO__)-import System.IO              (openBinaryTempFileWithDefaultPermissions)-#else-import Control.Exception      (onException)-import Data.Bits              ((.|.))-import Foreign.C              (CInt, eEXIST, getErrno, errnoToIOError)-import GHC.IO.Handle.FD       (fdToHandle)-import System.Posix.Internals (c_open, c_close, o_EXCL, o_BINARY, withFilePath,-                               o_CREAT, o_RDWR, o_NONBLOCK, o_NOCTTY)-#endif+import System.FilePath ((</>)) +import System.IO (Handle, openBinaryTempFile, openBinaryTempFileWithDefaultPermissions, openTempFile)+import System.IO.Error (isAlreadyExistsError) import System.Posix.Internals (c_getpid)-import System.IO.Error        (isAlreadyExistsError)  #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) import System.Directory       ( createDirectory )@@ -32,89 +22,8 @@ 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@@ -122,12 +31,14 @@   findTempName pid   where     findTempName x = do-      let dirpath = dir </> template ++ "-" ++ show x+      let relpath = template ++ "-" ++ show x+          dirpath = dir </> relpath       r <- tryIO $ mkPrivateDir dirpath       case r of-        Right _ -> return dirpath-        Left  e | isAlreadyExistsError e -> findTempName (x+1)-                | otherwise              -> ioError e+        Right _ -> return relpath+        Left e+          | isAlreadyExistsError e -> findTempName (x + 1)+          | otherwise -> ioError e  mkPrivateDir :: String -> IO () #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
− src/Distribution/Compat/Lens.hs 
@@ -1,262 +0,0 @@-{-# LANGUAGE RankNTypes #-}--- | This module provides very basic lens functionality, without extra dependencies.------ For the documentation of the combinators see <http://hackage.haskell.org/package/lens lens> package.--- This module uses the same vocabulary.-module Distribution.Compat.Lens (-    -- * Types-    Lens,-    Lens',-    Traversal,-    Traversal',-    -- ** LensLike-    LensLike,-    LensLike',-    -- ** rank-1 types-    Getting,-    AGetter,-    ASetter,-    ALens,-    ALens',-    -- * Getter-    view,-    use,-    getting,-    -- * Setter-    set,-    over,-    -- * Fold-    toDListOf,-    toListOf,-    toSetOf,-    -- * Lens-    cloneLens,-    aview,-    -- * Common lenses-    _1, _2,-    -- * Operators-    (&),-    (^.),-    (.~), (?~), (%~),-    (.=), (?=), (%=),-    (^#),-    (#~), (#%~),-    -- * Internal Comonads-    Pretext (..),-    -- * Cabal developer info-    -- $development-    ) where--import Prelude()-import Distribution.Compat.Prelude--import Control.Monad.State.Class (MonadState (..), gets, modify)--import qualified Distribution.Compat.DList as DList-import qualified Data.Set as Set------------------------------------------------------------------------------------ Types----------------------------------------------------------------------------------type LensLike  f s t a b = (a -> f b) -> s -> f t-type LensLike' f s   a   = (a -> f a) -> s -> f s--type Lens      s t a b = forall f. Functor f     => LensLike f s t a b-type Traversal s t a b = forall f. Applicative f => LensLike f s t a b--type Lens'      s a = Lens s s a a-type Traversal' s a = Traversal s s a a--type Getting r s a = LensLike (Const r) s s a a--type AGetter s   a   = LensLike (Const a)     s s a a  -- this doesn't exist in 'lens'-type ASetter s t a b = LensLike Identity      s t a b-type ALens   s t a b = LensLike (Pretext a b) s t a b--type ALens' s a = ALens s s a a------------------------------------------------------------------------------------ Getter----------------------------------------------------------------------------------view :: Getting a s a -> s ->  a-view l s = getConst (l Const s)-{-# INLINE view #-}--use :: MonadState s m => Getting a s a -> m a-use l = gets (view l)-{-# INLINE use #-}---- | @since 2.4------ >>> (3 :: Int) ^. getting (+2) . getting show--- "5"-getting :: (s -> a) -> Getting r s a-getting k f = Const . getConst . f . k-{-# INLINE getting #-}------------------------------------------------------------------------------------ Setter----------------------------------------------------------------------------------set :: ASetter s t a  b -> b -> s -> t-set l x = over l (const x)--over :: ASetter s t a b -> (a -> b) -> s -> t-over l f s = runIdentity (l (\x -> Identity (f x)) s)------------------------------------------------------------------------------------ Fold----------------------------------------------------------------------------------toDListOf :: Getting (DList.DList a) s a -> s -> DList.DList a-toDListOf l s = getConst (l (\x -> Const (DList.singleton x)) s)--toListOf :: Getting (DList.DList a) s a -> s -> [a]-toListOf l = DList.runDList . toDListOf l--toSetOf  :: Getting (Set.Set a) s a -> s -> Set.Set a-toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s)------------------------------------------------------------------------------------ Lens----------------------------------------------------------------------------------aview :: ALens s t a b -> s -> a-aview l = pretextPos  . l pretextSell-{-# INLINE aview #-}--{--lens :: (s -> a) -> (s -> a -> s) -> Lens' s a-lens sa sbt afb s = sbt s <$> afb (sa s)--}------------------------------------------------------------------------------------ Common----------------------------------------------------------------------------------_1 ::  Lens (a, c) (b, c) a b-_1 f (a, c) = flip (,) c <$> f a--_2 ::  Lens (c, a) (c, b) a b-_2 f (c, a) = (,) c <$> f a------------------------------------------------------------------------------------ Operators------------------------------------------------------------------------------------ | '&' is a reverse application operator-(&) :: a -> (a -> b) -> b-(&) = flip ($)-{-# INLINE (&) #-}-infixl 1 &--infixl 8 ^., ^#-infixr 4 .~, %~, ?~-infixr 4 #~, #%~-infixr 4 .=, %=, ?=--(^.) :: s -> Getting a s a -> a-s ^. l = getConst (l Const s)-{-# INLINE (^.) #-}--(.~) :: ASetter s t a b -> b -> s -> t-(.~) = set-{-# INLINE (.~) #-}--(?~) :: ASetter s t a (Maybe b) -> b -> s -> t-l ?~ b = set l (Just b)-{-# INLINE (?~) #-}--(%~) :: ASetter s t a b -> (a -> b) -> s -> t-(%~) = over-{-# INLINE (%~) #-}--(.=) :: MonadState s m => ASetter s s a b -> b -> m ()-l .= b = modify (l .~ b)-{-# INLINE (.=) #-}--(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m ()-l ?= b = modify (l ?~ b)-{-# INLINE (?=) #-}--(%=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m ()-l %= f = modify (l %~ f)-{-# INLINE (%=) #-}--(^#) :: s -> ALens s t a b -> a-s ^# l = aview l s--(#~) :: ALens s t a b -> b -> s -> t-(#~) l b s = pretextPeek b (l pretextSell s)-{-# INLINE (#~) #-}--(#%~) :: ALens s t a b -> (a -> b) -> s -> t-(#%~) l f s = pretextPeeks f (l pretextSell s)-{-# INLINE (#%~) #-}--pretextSell :: a -> Pretext a b b-pretextSell a = Pretext (\afb -> afb a)-{-# INLINE pretextSell #-}--pretextPeeks :: (a -> b) -> Pretext a b t -> t-pretextPeeks f (Pretext m) = runIdentity $ m (\x -> Identity (f x))-{-# INLINE pretextPeeks #-}--pretextPeek :: b -> Pretext a b t -> t-pretextPeek b (Pretext m) = runIdentity $ m (\_ -> Identity b)-{-# INLINE pretextPeek #-}--pretextPos :: Pretext a b t -> a-pretextPos (Pretext m) = getConst (m Const)-{-# INLINE pretextPos #-}--cloneLens :: Functor f => ALens s t a b -> LensLike f s t a b-cloneLens l f s = runPretext (l pretextSell s) f-{-# INLINE cloneLens #-}------------------------------------------------------------------------------------ Comonads------------------------------------------------------------------------------------ | @lens@ variant is also parametrised by profunctor.-data Pretext a b t = Pretext { runPretext :: forall f. Functor f => (a -> f b) -> f t }--instance Functor (Pretext a b) where-    fmap f (Pretext pretext) = Pretext (\afb -> fmap f (pretext afb))------------------------------------------------------------------------------------ Documentation------------------------------------------------------------------------------------ $development------ We cannot depend on @template-haskell@, because Cabal is a boot library.--- This fact makes defining optics a manual task. Here is a small recipe to--- make the process less tedious.------ First start a repl------ > cabal new-repl Cabal:hackage-tests------ Because @--extra-package@ isn't yet implemented, we use a test-suite--- with @generics-sop@ dependency.------ In the repl, we load a helper script:------ > :l ../generics-sop-lens.hs------ Now we are set up to derive lenses!------ > :m +Distribution.Types.SourceRepo--- > putStr $ genericLenses (Proxy :: Proxy SourceRepo)------ @--- repoKind :: Lens' SourceRepo RepoKind--- repoKind f s = fmap (\\x -> s { T.repoKind = x }) (f (T.repoKind s))--- \{-# INLINE repoKind #-\}--- ...--- @------ /Note:/ You may need to adjust type-aliases, e.g. `String` to `FilePath`.
− src/Distribution/Compat/MonadFail.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE CPP #-}---- | Compatibility layer for "Control.Monad.Fail"-module Distribution.Compat.MonadFail ( Control.Monad.Fail.MonadFail(fail) ) where-import Control.Monad.Fail
− src/Distribution/Compat/Newtype.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE DefaultSignatures      #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}--- | Per Conor McBride, the 'Newtype' typeclass represents the packing and--- unpacking of a newtype, and allows you to operatate under that newtype with--- functions such as 'ala'.-module Distribution.Compat.Newtype (-    Newtype (..),-    ala,-    alaf,-    pack',-    unpack',-    ) where--import Data.Functor.Identity (Identity (..))-import Data.Monoid (Sum (..), Product (..), Endo (..))--#if MIN_VERSION_base(4,7,0)-import Data.Coerce (coerce, Coercible)-#else-import Unsafe.Coerce (unsafeCoerce)-#endif---- | The @FunctionalDependencies@ version of 'Newtype' type-class.------ Since Cabal-3.0 class arguments are in a different order than in @newtype@ package.--- This change is to allow usage with @DeriveAnyClass@ (and @DerivingStrategies@, in GHC-8.2).--- Unfortunately one has to repeat inner type.------ @--- newtype New = New Old---   deriving anyclass (Newtype Old)--- @------ Another approach would be to use @TypeFamilies@ (and possibly--- compute inner type using "GHC.Generics"), but we think @FunctionalDependencies@--- version gives cleaner type signatures.----class Newtype o n | n -> o where-    pack   :: o -> n-#if MIN_VERSION_base(4,7,0)-    default pack :: Coercible o n => o -> n-    pack = coerce-#else-    default pack :: o -> n-    pack = unsafeCoerce-#endif--    unpack :: n -> o-#if MIN_VERSION_base(4,7,0)-    default unpack :: Coercible n o => n -> o-    unpack = coerce-#else-    default unpack :: n -> o-    unpack = unsafeCoerce-#endif--instance Newtype a (Identity a)-instance Newtype a (Sum a)-instance Newtype a (Product a)-instance Newtype (a -> a) (Endo a)---- |------ >>> ala Sum foldMap [1, 2, 3, 4 :: Int]--- 10------ /Note:/ the user supplied function for the newtype is /ignored/.------ >>> ala (Sum . (+1)) foldMap [1, 2, 3, 4 :: Int]--- 10-ala :: (Newtype o n, Newtype o' n') => (o -> n) -> ((o -> n) -> b -> n') -> (b -> o')-ala pa hof = alaf pa hof id---- |------ >>> alaf Sum foldMap length ["cabal", "install"]--- 12------ /Note:/ as with 'ala', the user supplied function for the newtype is /ignored/.-alaf :: (Newtype o n, Newtype o' n') => (o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> (b -> o')-alaf _ hof f = unpack . hof (pack . f)---- | Variant of 'pack', which takes a phantom type.-pack' :: Newtype o n => (o -> n) -> o -> n-pack' _ = pack---- | Variant of 'unpack', which takes a phantom type.-unpack' :: Newtype o n => (o -> n) -> n -> o-unpack' _ = unpack
− src/Distribution/Compat/NonEmptySet.hs 
@@ -1,155 +0,0 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-module Distribution.Compat.NonEmptySet (-    NonEmptySet,-    -- * Construction-    singleton,-    -- * Insertion-    insert,-    -- * Deletion-    delete,-    -- * Conversions-    toNonEmpty,-    fromNonEmpty,-    toList,-    toSet,-    -- * Query-    member,-    -- * Map-    map,-) where--import Prelude (Bool (..), Eq, Maybe (..), Ord (..), Read, Show (..), String, error, otherwise, return, showParen, showString, ($), (++), (.))--import Control.DeepSeq    (NFData (..))-import Data.Data          (Data)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Semigroup     (Semigroup (..))-import Data.Typeable      (Typeable)--import qualified Data.Foldable as F-import qualified Data.Set      as Set--import Distribution.Compat.Binary    (Binary (..))-import Distribution.Utils.Structured--#if MIN_VERSION_binary(0,6,0)-import Control.Applicative (empty)-#else-import Control.Monad (fail)-#endif---- | @since 3.4.0.0-newtype NonEmptySet a = NES (Set.Set a)-  deriving (Eq, Ord, Typeable, Data, Read)------------------------------------------------------------------------------------ Instances----------------------------------------------------------------------------------instance Show a => Show (NonEmptySet a) where-    showsPrec d s = showParen (d > 10)-        $ showString "fromNonEmpty "-        . showsPrec 11 (toNonEmpty s)--instance Binary a => Binary (NonEmptySet a) where-    put (NES s) = put s-    get = do-        xs <- get-        if Set.null xs-#if MIN_VERSION_binary(0,6,0)-        then empty-#else-        then fail "NonEmptySet: empty"-#endif-        else return (NES xs)--instance Structured a => Structured (NonEmptySet a) where-    structure = containerStructure--instance NFData a => NFData (NonEmptySet a) where-    rnf (NES x) = rnf x---- | Note: there aren't @Monoid@ instance.-instance Ord a => Semigroup (NonEmptySet a) where-    NES x <> NES y = NES (Set.union x y)--instance F.Foldable NonEmptySet where-    foldMap f (NES s) = F.foldMap f s-    foldr f z (NES s) = F.foldr f z s--#if MIN_VERSION_base(4,8,0)-    toList         = toList-    null _         = False-    length (NES s) = F.length s-#endif------------------------------------------------------------------------------------ Constructors----------------------------------------------------------------------------------singleton :: a -> NonEmptySet a-singleton = NES . Set.singleton------------------------------------------------------------------------------------ Insertion----------------------------------------------------------------------------------insert :: Ord a => a -> NonEmptySet a -> NonEmptySet a-insert x (NES xs) = NES (Set.insert x xs)------------------------------------------------------------------------------------ Deletion----------------------------------------------------------------------------------delete :: Ord a => a -> NonEmptySet a -> Maybe (NonEmptySet a)-delete x (NES xs)-    | Set.null res = Nothing-    | otherwise    = Just (NES xs)-  where-    res = Set.delete x xs------------------------------------------------------------------------------------ Conversions----------------------------------------------------------------------------------fromNonEmpty :: Ord a => NonEmpty a -> NonEmptySet a-fromNonEmpty (x :| xs) = NES (Set.fromList (x : xs))--toNonEmpty :: NonEmptySet a -> NonEmpty a-toNonEmpty (NES s) = case Set.toList s of-    []   -> panic "toNonEmpty"-    x:xs -> x :| xs--toList :: NonEmptySet a -> [a]-toList (NES s) = Set.toList s--toSet :: NonEmptySet a -> Set.Set a-toSet (NES s) = s------------------------------------------------------------------------------------ Query----------------------------------------------------------------------------------member :: Ord a => a -> NonEmptySet a -> Bool-member x (NES xs) = Set.member x xs------------------------------------------------------------------------------------ Map----------------------------------------------------------------------------------map-    :: ( Ord b-#if !MIN_VERSION_containers(0,5,2)-       , Ord a-#endif-       )-    => (a -> b) -> NonEmptySet a -> NonEmptySet b-map f (NES x) = NES (Set.map f x)------------------------------------------------------------------------------------ Internal----------------------------------------------------------------------------------panic :: String -> a-panic msg = error $ "NonEmptySet invariant violated: " ++ msg
− src/Distribution/Compat/Parsing.hs 
@@ -1,362 +0,0 @@-{-# LANGUAGE GADTs, UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Compat.Parsing--- Copyright   :  (c) Edward Kmett 2011-2012--- License     :  BSD3------ Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  non-portable------ Alternative parser combinators.------ Originally in @parsers@ package.----------------------------------------------------------------------------------module Distribution.Compat.Parsing-  (-  -- * Parsing Combinators-    choice-  , option-  , optional -- from Control.Applicative, parsec optionMaybe-  , skipOptional -- parsec optional-  , between-  , some     -- from Control.Applicative, parsec many1-  , many     -- from Control.Applicative-  , sepBy-  , sepByNonEmpty-  , sepEndByNonEmpty-  , sepEndBy-  , endByNonEmpty-  , endBy-  , count-  , chainl-  , chainr-  , chainl1-  , chainr1-  , manyTill-  -- * Parsing Class-  , Parsing(..)-  ) where--import Prelude ()-import Distribution.Compat.Prelude--import Control.Applicative ((<**>), optional)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.State.Lazy as Lazy-import Control.Monad.Trans.State.Strict as Strict-import Control.Monad.Trans.Writer.Lazy as Lazy-import Control.Monad.Trans.Writer.Strict as Strict-import Control.Monad.Trans.RWS.Lazy as Lazy-import Control.Monad.Trans.RWS.Strict as Strict-import Control.Monad.Trans.Reader (ReaderT (..))-import Control.Monad.Trans.Identity (IdentityT (..))-import Data.Foldable (asum)--import qualified Data.List.NonEmpty as NE-import qualified Text.Parsec as Parsec---- | @choice ps@ tries to apply the parsers in the list @ps@ in order,--- until one of them succeeds. Returns the value of the succeeding--- parser.-choice :: Alternative m => [m a] -> m a-choice = asum-{-# INLINE choice #-}---- | @option x p@ tries to apply parser @p@. If @p@ fails without--- consuming input, it returns the value @x@, otherwise the value--- returned by @p@.------ >  priority = option 0 (digitToInt <$> digit)-option :: Alternative m => a -> m a -> m a-option x p = p <|> pure x-{-# INLINE option #-}---- | @skipOptional p@ tries to apply parser @p@.  It will parse @p@ or nothing.--- It only fails if @p@ fails after consuming input. It discards the result--- of @p@. (Plays the role of parsec's optional, which conflicts with Applicative's optional)-skipOptional :: Alternative m => m a -> m ()-skipOptional p = (() <$ p) <|> pure ()-{-# INLINE skipOptional #-}---- | @between open close p@ parses @open@, followed by @p@ and @close@.--- Returns the value returned by @p@.------ >  braces  = between (symbol "{") (symbol "}")-between :: Applicative m => m bra -> m ket -> m a -> m a-between bra ket p = bra *> p <* ket-{-# INLINE between #-}---- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated--- by @sep@. Returns a list of values returned by @p@.------ >  commaSep p  = p `sepBy` (symbol ",")-sepBy :: Alternative m => m a -> m sep -> m [a]-sepBy p sep = toList <$> sepByNonEmpty p sep <|> pure []-{-# INLINE sepBy #-}---- | @sepByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated--- by @sep@. Returns a non-empty list of values returned by @p@.-sepByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a)-sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p)-{-# INLINE sepByNonEmpty #-}---- | @sepEndByNonEmpty p sep@ parses /one/ or more occurrences of @p@,--- separated and optionally ended by @sep@. Returns a non-empty list of values--- returned by @p@.-sepEndByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a)-sepEndByNonEmpty p sep = (:|) <$> p <*> ((sep *> sepEndBy p sep) <|> pure [])---- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@,--- separated and optionally ended by @sep@, ie. haskell style--- statements. Returns a list of values returned by @p@.------ >  haskellStatements  = haskellStatement `sepEndBy` semi-sepEndBy :: Alternative m => m a -> m sep -> m [a]-sepEndBy p sep = toList <$> sepEndByNonEmpty p sep <|> pure []-{-# INLINE sepEndBy #-}---- | @endByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated--- and ended by @sep@. Returns a non-empty list of values returned by @p@.-endByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a)-endByNonEmpty p sep = NE.some1 (p <* sep)-{-# INLINE endByNonEmpty #-}---- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated--- and ended by @sep@. Returns a list of values returned by @p@.------ >   cStatements  = cStatement `endBy` semi-endBy :: Alternative m => m a -> m sep -> m [a]-endBy p sep = many (p <* sep)-{-# INLINE endBy #-}---- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or--- equal to zero, the parser equals to @return []@. Returns a list of--- @n@ values returned by @p@.-count :: Applicative m => Int -> m a -> m [a]-count n p | n <= 0    = pure []-          | otherwise = sequenceA (replicate n p)-{-# INLINE count #-}---- | @chainr p op x@ parses /zero/ or more occurrences of @p@,--- separated by @op@ Returns a value obtained by a /right/ associative--- application of all functions returned by @op@ to the values returned--- by @p@. If there are no occurrences of @p@, the value @x@ is--- returned.-chainr :: Alternative m => m a -> m (a -> a -> a) -> a -> m a-chainr p op x = chainr1 p op <|> pure x-{-# INLINE chainr #-}---- | @chainl p op x@ parses /zero/ or more occurrences of @p@,--- separated by @op@. Returns a value obtained by a /left/ associative--- application of all functions returned by @op@ to the values returned--- by @p@. If there are zero occurrences of @p@, the value @x@ is--- returned.-chainl :: Alternative m => m a -> m (a -> a -> a) -> a -> m a-chainl p op x = chainl1 p op <|> pure x-{-# INLINE chainl #-}---- | @chainl1 p op x@ parses /one/ or more occurrences of @p@,--- separated by @op@ Returns a value obtained by a /left/ associative--- application of all functions returned by @op@ to the values returned--- by @p@. . This parser can for example be used to eliminate left--- recursion which typically occurs in expression grammars.------ >  expr   = term   `chainl1` addop--- >  term   = factor `chainl1` mulop--- >  factor = parens expr <|> integer--- >--- >  mulop  = (*) <$ symbol "*"--- >       <|> div <$ symbol "/"--- >--- >  addop  = (+) <$ symbol "+"--- >       <|> (-) <$ symbol "-"-chainl1 :: Alternative m => m a -> m (a -> a -> a) -> m a-chainl1 p op = scan where-  scan = p <**> rst-  rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id-{-# INLINE chainl1 #-}---- | @chainr1 p op x@ parses /one/ or more occurrences of @p@,--- separated by @op@ Returns a value obtained by a /right/ associative--- application of all functions returned by @op@ to the values returned--- by @p@.-chainr1 :: Alternative m => m a -> m (a -> a -> a) -> m a-chainr1 p op = scan where-  scan = p <**> rst-  rst = (flip <$> op <*> scan) <|> pure id-{-# INLINE chainr1 #-}---- | @manyTill p end@ applies parser @p@ /zero/ or more times until--- parser @end@ succeeds. Returns the list of values returned by @p@.--- This parser can be used to scan comments:------ >  simpleComment   = do{ string "<!--"--- >                      ; manyTill anyChar (try (string "-->"))--- >                      }------    Note the overlapping parsers @anyChar@ and @string \"-->\"@, and---    therefore the use of the 'try' combinator.-manyTill :: Alternative m => m a -> m end -> m [a]-manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go)-{-# INLINE manyTill #-}--infixr 0 <?>---- | Additional functionality needed to describe parsers independent of input type.-class Alternative m => Parsing m where-  -- | Take a parser that may consume input, and on failure, go back to-  -- where we started and fail as if we didn't consume input.-  try :: m a -> m a--  -- | Give a parser a name-  (<?>) :: m a -> String -> m a--  -- | A version of many that discards its input. Specialized because it-  -- can often be implemented more cheaply.-  skipMany :: m a -> m ()-  skipMany p = () <$ many p-  {-# INLINE skipMany #-}--  -- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping-  -- its result. (aka skipMany1 in parsec)-  skipSome :: m a -> m ()-  skipSome p = p *> skipMany p-  {-# INLINE skipSome #-}--  -- | Used to emit an error on an unexpected token-  unexpected :: String -> m a--  -- | This parser only succeeds at the end of the input. This is not a-  -- primitive parser but it is defined using 'notFollowedBy'.-  ---  -- >  eof  = notFollowedBy anyChar <?> "end of input"-  eof :: m ()--  -- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser-  -- does not consume any input. This parser can be used to implement the-  -- \'longest match\' rule. For example, when recognizing keywords (for-  -- example @let@), we want to make sure that a keyword is not followed-  -- by a legal identifier character, in which case the keyword is-  -- actually an identifier (for example @lets@). We can program this-  -- behaviour as follows:-  ---  -- >  keywordLet  = try $ string "let" <* notFollowedBy alphaNum-  notFollowedBy :: Show a => m a -> m ()--instance (Parsing m, MonadPlus m) => Parsing (Lazy.StateT s m) where-  try (Lazy.StateT m) = Lazy.StateT $ try . m-  {-# INLINE try #-}-  Lazy.StateT m <?> l = Lazy.StateT $ \s -> m s <?> l-  {-# INLINE (<?>) #-}-  unexpected = lift . unexpected-  {-# INLINE unexpected #-}-  eof = lift eof-  {-# INLINE eof #-}-  notFollowedBy (Lazy.StateT m) = Lazy.StateT-    $ \s -> notFollowedBy (fst <$> m s) >> return ((),s)-  {-# INLINE notFollowedBy #-}--instance (Parsing m, MonadPlus m) => Parsing (Strict.StateT s m) where-  try (Strict.StateT m) = Strict.StateT $ try . m-  {-# INLINE try #-}-  Strict.StateT m <?> l = Strict.StateT $ \s -> m s <?> l-  {-# INLINE (<?>) #-}-  unexpected = lift . unexpected-  {-# INLINE unexpected #-}-  eof = lift eof-  {-# INLINE eof #-}-  notFollowedBy (Strict.StateT m) = Strict.StateT-    $ \s -> notFollowedBy (fst <$> m s) >> return ((),s)-  {-# INLINE notFollowedBy #-}--instance (Parsing m, MonadPlus m) => Parsing (ReaderT e m) where-  try (ReaderT m) = ReaderT $ try . m-  {-# INLINE try #-}-  ReaderT m <?> l = ReaderT $ \e -> m e <?> l-  {-# INLINE (<?>) #-}-  skipMany (ReaderT m) = ReaderT $ skipMany . m-  {-# INLINE skipMany #-}-  unexpected = lift . unexpected-  {-# INLINE unexpected #-}-  eof = lift eof-  {-# INLINE eof #-}-  notFollowedBy (ReaderT m) = ReaderT $ notFollowedBy . m-  {-# INLINE notFollowedBy #-}--instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.WriterT w m) where-  try (Strict.WriterT m) = Strict.WriterT $ try m-  {-# INLINE try #-}-  Strict.WriterT m <?> l = Strict.WriterT (m <?> l)-  {-# INLINE (<?>) #-}-  unexpected = lift . unexpected-  {-# INLINE unexpected #-}-  eof = lift eof-  {-# INLINE eof #-}-  notFollowedBy (Strict.WriterT m) = Strict.WriterT-    $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty)-  {-# INLINE notFollowedBy #-}--instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.WriterT w m) where-  try (Lazy.WriterT m) = Lazy.WriterT $ try m-  {-# INLINE try #-}-  Lazy.WriterT m <?> l = Lazy.WriterT (m <?> l)-  {-# INLINE (<?>) #-}-  unexpected = lift . unexpected-  {-# INLINE unexpected #-}-  eof = lift eof-  {-# INLINE eof #-}-  notFollowedBy (Lazy.WriterT m) = Lazy.WriterT-    $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty)-  {-# INLINE notFollowedBy #-}--instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.RWST r w s m) where-  try (Lazy.RWST m) = Lazy.RWST $ \r s -> try (m r s)-  {-# INLINE try #-}-  Lazy.RWST m <?> l = Lazy.RWST $ \r s -> m r s <?> l-  {-# INLINE (<?>) #-}-  unexpected = lift . unexpected-  {-# INLINE unexpected #-}-  eof = lift eof-  {-# INLINE eof #-}-  notFollowedBy (Lazy.RWST m) = Lazy.RWST-    $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty)-  {-# INLINE notFollowedBy #-}--instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.RWST r w s m) where-  try (Strict.RWST m) = Strict.RWST $ \r s -> try (m r s)-  {-# INLINE try #-}-  Strict.RWST m <?> l = Strict.RWST $ \r s -> m r s <?> l-  {-# INLINE (<?>) #-}-  unexpected = lift . unexpected-  {-# INLINE unexpected #-}-  eof = lift eof-  {-# INLINE eof #-}-  notFollowedBy (Strict.RWST m) = Strict.RWST-    $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty)-  {-# INLINE notFollowedBy #-}--instance (Parsing m, Monad m) => Parsing (IdentityT m) where-  try = IdentityT . try . runIdentityT-  {-# INLINE try #-}-  IdentityT m <?> l = IdentityT (m <?> l)-  {-# INLINE (<?>) #-}-  skipMany = IdentityT . skipMany . runIdentityT-  {-# INLINE skipMany #-}-  unexpected = lift . unexpected-  {-# INLINE unexpected #-}-  eof = lift eof-  {-# INLINE eof #-}-  notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m-  {-# INLINE notFollowedBy #-}--instance (Parsec.Stream s m t, Show t) => Parsing (Parsec.ParsecT s u m) where-  try           = Parsec.try-  (<?>)         = (Parsec.<?>)-  skipMany      = Parsec.skipMany-  skipSome      = Parsec.skipMany1-  unexpected    = Parsec.unexpected-  eof           = Parsec.eof-  notFollowedBy = Parsec.notFollowedBy
− src/Distribution/Compat/Prelude.hs 
@@ -1,316 +0,0 @@-{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes       #-}-{-# LANGUAGE Trustworthy      #-}-{-# LANGUAGE TypeOperators    #-}--#ifdef MIN_VERSION_base-#define MINVER_base_411 MIN_VERSION_base(4,11,0)-#define MINVER_base_48 MIN_VERSION_base(4,8,0)-#define MINVER_base_47 MIN_VERSION_base(4,7,0)-#else-#define MINVER_base_411 (__GLASGOW_HASKELL__ >= 804)-#define MINVER_base_48 (__GLASGOW_HASKELL__ >= 710)-#define MINVER_base_47 (__GLASGOW_HASKELL__ >= 708)-#endif---- | This module does two things:------ * Acts as a compatibility layer, like @base-compat@.------ * Provides commonly used imports.-module Distribution.Compat.Prelude (-    -- * Prelude-    ---    -- Prelude is re-exported, following is hidden:-    module BasePrelude,--#if !MINVER_base_48-    -- * base 4.8 shim-    Applicative(..), (<$), (<$>),-    Monoid(..),-#endif--    -- * Common type-classes-    Semigroup (..),-    gmappend, gmempty,-    Typeable, TypeRep, typeRep,-    Data,-    Generic,-    NFData (..), genericRnf,-    Binary (..),-    Structured,-    Alternative (..),-    MonadPlus (..),-    IsString (..),--    -- * Some types-    Map,-    Set,-    NonEmptySet,-    Identity (..),-    Proxy (..),-    Const (..),-    Void,--    -- * Data.Either-    partitionEithers,--    -- * Data.Maybe-    catMaybes, mapMaybe,-    fromMaybe,-    maybeToList, listToMaybe,-    isNothing, isJust,--    -- * Data.List-    unfoldr,-    isPrefixOf, isSuffixOf,-    intercalate, intersperse,-    sort, sortBy,-    nub, nubBy,-    partition,--    -- * Data.List.NonEmpty-    NonEmpty((:|)), nonEmpty, foldl1, foldr1,-    head, tail, last, init,--    -- * Data.Foldable-    Foldable, foldMap, foldr,-    null, length,-    find, foldl',-    traverse_, for_,-    any, all,-    toList,--    -- * Data.Traversable-    Traversable, traverse, sequenceA,-    for,--    -- * Data.Function-    on,--    -- * Data.Ord-    comparing,--    -- * Control.Arrow-    first,--    -- * Control.Monad-    liftM, liftM2,-    unless, when,-    ap, void,-    foldM, filterM,-    join, guard,--    -- * Control.Exception-    catch, throwIO, evaluate,-    Exception (..), IOException, SomeException (..),-#if !MINVER_base_48-    displayException,-#endif-    tryIO, catchIO, catchExit,--    -- * Control.DeepSeq-    deepseq, force,--    -- * Data.Char-    isSpace, isDigit, isUpper, isAlpha, isAlphaNum,-    chr, ord,-    toLower, toUpper,--    -- * Data.Void-    absurd, vacuous,--    -- * Data.Word & Data.Int-    Word,-    Word8, Word16, Word32, Word64,-    Int8, Int16, Int32, Int64,--    -- * Text.PrettyPrint-    (<<>>), (Disp.<+>),--    -- * System.Exit-    ExitCode (..),-    exitWith, exitSuccess, exitFailure,--    -- * Text.Read-    readMaybe,--    -- * Debug.Trace (as deprecated functions)-    trace, traceShow, traceShowId,-    ) where---- We also could hide few partial function-import Prelude                       as BasePrelude hiding-  ( mapM, mapM_, sequence, null, length, foldr, any, all, head, tail, last, init-  -- partial functions-  , read-  , foldr1, foldl1-#if MINVER_base_411-  -- As of base 4.11.0.0 Prelude exports part of Semigroup(..).-  -- Hide this so we instead rely on Distribution.Compat.Semigroup.-  , Semigroup(..)-#endif-#if MINVER_base_48-  , Word-  -- We hide them, as we import only some members-  , Traversable, traverse, sequenceA-  , Foldable, foldMap-#endif-  )---- AMP-#if !MINVER_base_48-import Control.Applicative           (Applicative (..), (<$), (<$>))-import Data.Foldable                 (toList)-import Distribution.Compat.Semigroup (Monoid (..))-#else-import Data.Foldable (Foldable (toList), length, null)-#endif--import Data.Foldable    (Foldable (foldMap, foldr), all, any, find, foldl', for_, traverse_)-import Data.Traversable (Traversable (sequenceA, traverse), for)--import qualified Data.Foldable---- Extra exports-import Control.Applicative           (Alternative (..))-import Control.Applicative           (Const (..))-import Control.Arrow                 (first)-import Control.DeepSeq               (NFData (..), deepseq, force)-import Control.Exception             (Exception (..), IOException, SomeException (..), catch, evaluate, throwIO)-import Control.Monad                 (MonadPlus (..), ap, filterM, foldM, guard, join, liftM, liftM2, unless, void, when)-import Data.Char                     (chr, isAlpha, isAlphaNum, isDigit, isSpace, isUpper, ord, toLower, toUpper)-import Data.Data                     (Data)-import Data.Either                   (partitionEithers)-import Data.Function                 (on)-import Data.Functor.Identity         (Identity (..))-import Data.Int                      (Int16, Int32, Int64, Int8)-import Data.List                     (intercalate, intersperse, isPrefixOf, isSuffixOf, nub, nubBy, partition, sort, sortBy, unfoldr)-import Data.List.NonEmpty            (NonEmpty ((:|)), nonEmpty, head, init, last, tail)-import Data.Map                      (Map)-import Data.Maybe                    (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList)-import Data.Ord                      (comparing)-import Data.Proxy                    (Proxy (..))-import Data.Set                      (Set)-import Data.String                   (IsString (..))-import Data.Void                     (Void, absurd, vacuous)-import Data.Word                     (Word, Word16, Word32, Word64, Word8)-import Distribution.Compat.Binary    (Binary (..))-import Distribution.Compat.Semigroup (Semigroup (..), gmappend, gmempty)-import Distribution.Compat.Typeable  (TypeRep, Typeable, typeRep)-import GHC.Generics                  ((:*:) ((:*:)), (:+:) (L1, R1), Generic, K1 (unK1), M1 (unM1), Rep (..), U1 (U1), V1)-import System.Exit                   (ExitCode (..), exitFailure, exitSuccess, exitWith)-import Text.Read                     (readMaybe)--import qualified Text.PrettyPrint as Disp--import Distribution.Compat.Exception-import Distribution.Compat.NonEmptySet (NonEmptySet)-import Distribution.Utils.Structured   (Structured)--import qualified Debug.Trace---- | New name for 'Text.PrettyPrint.<>'-(<<>>) :: Disp.Doc -> Disp.Doc -> Disp.Doc-(<<>>) = (Disp.<>)--#if !MINVER_base_48--- | Test whether the structure is empty. The default implementation is--- optimized for structures that are similar to cons-lists, because there--- is no general way to do better.-null :: Foldable t => t a -> Bool-null = foldr (\_ _ -> False) True---- | Returns the size/length of a finite structure as an 'Int'.  The--- default implementation is optimized for structures that are similar to--- cons-lists, because there is no general way to do better.-length :: Foldable t => t a -> Int-length = foldl' (\c _ -> c+1) 0-#endif----- | "GHC.Generics"-based 'rnf' implementation------ This is needed in order to support @deepseq < 1.4@ which didn't--- have a 'Generic'-based default 'rnf' implementation yet.------ In order to define instances, use e.g.------ > instance NFData MyType where rnf = genericRnf------ The implementation has been taken from @deepseq-1.4.2@'s default--- 'rnf' implementation.-genericRnf :: (Generic a, GNFData (Rep a)) => a -> ()-genericRnf = grnf . from---- | Hidden internal type-class-class GNFData f where-  grnf :: f a -> ()--instance GNFData V1 where-  grnf = error "Control.DeepSeq.rnf: uninhabited type"--instance GNFData U1 where-  grnf U1 = ()--instance NFData a => GNFData (K1 i a) where-  grnf = rnf . unK1-  {-# INLINEABLE grnf #-}--instance GNFData a => GNFData (M1 i c a) where-  grnf = grnf . unM1-  {-# INLINEABLE grnf #-}--instance (GNFData a, GNFData b) => GNFData (a :*: b) where-  grnf (x :*: y) = grnf x `seq` grnf y-  {-# INLINEABLE grnf #-}--instance (GNFData a, GNFData b) => GNFData (a :+: b) where-  grnf (L1 x) = grnf x-  grnf (R1 x) = grnf x-  {-# INLINEABLE grnf #-}----- TODO: if we want foldr1/foldl1 to work on more than NonEmpty, we--- can define a local typeclass 'Foldable1', e.g.------ @--- class Foldable f => Foldable1 f------ instance Foldable1 NonEmpty------ foldr1 :: Foldable1 t => (a -> a -> a) -> t a -> a--- foldr1 = Data.Foldable.foldr1------ foldl1 :: Foldable1 t => (a -> a -> a) -> t a -> a--- foldl1 = Data.Foldable.foldl1--- @-----{-# INLINE foldr1 #-}-foldr1 :: (a -> a -> a) -> NonEmpty a -> a-foldr1 = Data.Foldable.foldr1--{-# INLINE foldl1 #-}-foldl1 :: (a -> a -> a) -> NonEmpty a -> a-foldl1 = Data.Foldable.foldl1------------------------------------------------------------------------------------ Trace------------------------------------------------------------------------------------ Functions from Debug.Trace--- but with DEPRECATED pragma, so -Werror will scream on them.--trace :: String -> a -> a-trace = Debug.Trace.trace-{-# DEPRECATED trace "Don't leave me in the code" #-}--traceShowId :: Show a => a -> a-traceShowId x = Debug.Trace.traceShow x x-{-# DEPRECATED traceShowId "Don't leave me in the code" #-}--traceShow :: Show a => a -> b -> b-traceShow = Debug.Trace.traceShow-{-# DEPRECATED traceShow "Don't leave me in the code" #-}
src/Distribution/Compat/Prelude/Internal.hs view
@@ -7,8 +7,8 @@ -- for @Setup.hs@ scripts since its API is /not/ -- stable. module Distribution.Compat.Prelude.Internal-    {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-}-    ( module Distribution.Compat.Prelude-    ) where+  {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-}+  ( module Distribution.Compat.Prelude+  ) where  import Distribution.Compat.Prelude
src/Distribution/Compat/Process.hs view
@@ -1,22 +1,15 @@ {-# LANGUAGE CPP #-}-module Distribution.Compat.Process (-    -- * Redefined functions-    createProcess,-    runInteractiveProcess,-    rawSystem,-    -- * Additions-    enableProcessJobs,-    ) where -import System.Exit (ExitCode (..))-import System.IO   (Handle)+module Distribution.Compat.Process+  ( -- * Redefined functions+    proc -import           System.Process (CreateProcess, ProcessHandle)-import qualified System.Process as Process+    -- * Additions+  , enableProcessJobs+  ) where -#if MIN_VERSION_process(1,2,0)-import           System.Process (waitForProcess)-#endif+import System.Process (CreateProcess)+import qualified System.Process as Process  #if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9) import           System.IO.Unsafe (unsafePerformIO)@@ -48,7 +41,7 @@ -- On Windows 7 or before the jobs are disabled due to the fact that -- processes on these systems can only have one job. This prevents -- spawned process from assigning jobs to its own children. Suppose--- processs A spawns process B. The B process has a job assigned (call+-- process A spawns process B. The B process has a job assigned (call -- it J1) and when it tries to spawn a new process C the C -- automatically inherits the job. But at it also tries to assign a -- new job J2 to C since it doesn’t have access J1. This fails on@@ -64,40 +57,7 @@ -- process redefinitions ------------------------------------------------------------------------------- --- | 'System.Process.createProcess' with process jobs enabled when appropriate.--- See 'enableProcessJobs'.-createProcess :: CreateProcess-              -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)-createProcess = Process.createProcess . enableProcessJobs---- | 'System.Process.rawSystem' with process jobs enabled when appropriate.--- See 'enableProcessJobs'.-rawSystem :: String -> [String] -> IO ExitCode-rawSystem cmd args = do-#if MIN_VERSION_process(1,2,0)-  (_,_,_,p) <- createProcess (Process.proc cmd args) { Process.delegate_ctlc = True }-  waitForProcess p-#else-  -- With very old 'process', just do its rawSystem-  Process.rawSystem cmd args-#endif---- | 'System.Process.runInteractiveProcess' with process jobs enabled when--- appropriate. See 'enableProcessJobs'.-runInteractiveProcess-  :: FilePath                   -- ^ Filename of the executable (see 'RawCommand' for details)-  -> [String]                   -- ^ Arguments to pass to the executable-  -> Maybe FilePath             -- ^ Optional path to the working directory-  -> Maybe [(String,String)]    -- ^ Optional environment (otherwise inherit)-  -> IO (Handle,Handle,Handle,ProcessHandle)-runInteractiveProcess cmd args mb_cwd mb_env = do-  (mb_in, mb_out, mb_err, p) <--      createProcess (Process.proc cmd args)-              { Process.std_in  = Process.CreatePipe,-                Process.std_out = Process.CreatePipe,-                Process.std_err = Process.CreatePipe,-                Process.env     = mb_env,-                Process.cwd     = mb_cwd }-  return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p)-  where-    fromJust = maybe (error "runInteractiveProcess: fromJust") id+-- | 'System.Process.proc' with process jobs enabled when appropriate,+-- and defaulting 'delegate_ctlc' to 'True'.+proc :: FilePath -> [String] -> CreateProcess+proc path args = enableProcessJobs (Process.proc path args){Process.delegate_ctlc = True}
src/Distribution/Compat/ResponseFile.hs view
@@ -1,54 +1,27 @@-{-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-}+{-# 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) where+module Distribution.Compat.ResponseFile (expandResponse, escapeArgs) where  import Distribution.Compat.Prelude++import GHC.ResponseFile (escapeArgs, unescapeArgs)+ import Prelude ()  import System.FilePath import System.IO (hPutStrLn, stderr) import System.IO.Error -#if MIN_VERSION_base(4,12,0)-import GHC.ResponseFile (unescapeArgs)-#else--unescapeArgs :: String -> [String]-unescapeArgs = filter (not . null) . unescape--data Quoting = NoneQ | SngQ | DblQ--unescape :: String -> [String]-unescape args = reverse . map reverse $ go args NoneQ False [] []-    where-      -- n.b., the order of these cases matters; these are cribbed from gcc-      -- case 1: end of input-      go []     _q    _bs   a as = a:as-      -- case 2: back-slash escape in progress-      go (c:cs) q     True  a as = go cs q     False (c:a) as-      -- case 3: no back-slash escape in progress, but got a back-slash-      go (c:cs) q     False a as-        | '\\' == c              = go cs q     True  a     as-      -- case 4: single-quote escaping in progress-      go (c:cs) SngQ  False a as-        | '\'' == c              = go cs NoneQ False a     as-        | otherwise              = go cs SngQ  False (c:a) as-      -- case 5: double-quote escaping in progress-      go (c:cs) DblQ  False a as-        | '"' == c               = go cs NoneQ False a     as-        | otherwise              = go cs DblQ  False (c:a) as-      -- case 6: no escaping is in progress-      go (c:cs) NoneQ False a as-        | isSpace c              = go cs NoneQ False []    (a:as)-        | '\'' == c              = go cs SngQ  False a     as-        | '"'  == c              = go cs DblQ  False a     as-        | otherwise              = go cs NoneQ False (c:a) as--#endif-+-- | The arg file / response file parser.+--+-- This is not a well-documented capability, and is a bit eccentric+-- (try @cabal \@foo \@bar@ to see what that does), but is crucial+-- for allowing complex arguments to cabal and cabal-install when+-- using command prompts with strongly-limited argument length. expandResponse :: [String] -> IO [String] expandResponse = go recursionLimit "."   where@@ -56,11 +29,11 @@      go :: Int -> FilePath -> [String] -> IO [String]     go n dir-      | n >= 0    = fmap concat . traverse (expand n dir)+      | n >= 0 = fmap concat . traverse (expand n dir)       | otherwise = const $ hPutStrLn stderr "Error: response file recursion limit exceeded." >> exitFailure      expand :: Int -> FilePath -> String -> IO [String]-    expand n dir arg@('@':f) = readRecursively n (dir </> f) `catchIOError` (const $ print "?" >> return [arg])+    expand n dir arg@('@' : f) = readRecursively n (dir </> f) `catchIOError` const (print "?" >> return [arg])     expand _n _dir x = return [x]      readRecursively :: Int -> FilePath -> IO [String]
− src/Distribution/Compat/Semigroup.hs 
@@ -1,119 +0,0 @@-{-# LANGUAGE CPP                         #-}-{-# LANGUAGE DeriveDataTypeable          #-}-{-# LANGUAGE DeriveGeneric               #-}-{-# LANGUAGE FlexibleContexts            #-}-{-# LANGUAGE GeneralizedNewtypeDeriving  #-}-{-# LANGUAGE TypeOperators               #-}---- | Compatibility layer for "Data.Semigroup"-module Distribution.Compat.Semigroup-    ( Semigroup((<>))-    , Mon.Monoid(..)-    , All(..)-    , Any(..)--    , First'(..)-    , Last'(..)--    , Option'(..)--    , gmappend-    , gmempty-    ) where--import Distribution.Compat.Binary (Binary)-import Distribution.Utils.Structured (Structured)-import Data.Typeable (Typeable)--import GHC.Generics--- Data.Semigroup is available since GHC 8.0/base-4.9 in `base`--- for older GHC/base, it's provided by `semigroups`-import Data.Semigroup-import qualified Data.Monoid as Mon----- | A copy of 'Data.Semigroup.First'.-newtype First' a = First' { getFirst' :: a }-  deriving (Eq, Ord, Show)--instance Semigroup (First' a) where-  a <> _ = a---- | A copy of 'Data.Semigroup.Last'.-newtype Last' a = Last' { getLast' :: a }-  deriving (Eq, Ord, Read, Show, Generic, Binary, Typeable)--instance Structured a => Structured (Last' a)--instance Semigroup (Last' a) where-  _ <> b = b--instance Functor Last' where-  fmap f (Last' x) = Last' (f x)---- | A wrapper around 'Maybe', providing the 'Semigroup' and 'Monoid' instances--- implemented for 'Maybe' since @base-4.11@.-newtype Option' a = Option' { getOption' :: Maybe a }-  deriving (Eq, Ord, Read, Show, Binary, Generic, Functor, Typeable)--instance Structured a => Structured (Option' a)--instance Semigroup a => Semigroup (Option' a) where-  Option' (Just a) <> Option' (Just b) = Option' (Just (a <> b))-  Option' Nothing  <> b                = b-  a                <> Option' Nothing  = a--instance Semigroup a => Monoid (Option' a) where-  mempty = Option' Nothing-  mappend = (<>)-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Stolen from Edward Kmett's BSD3-licensed `semigroups` package---- | Generically generate a 'Semigroup' ('<>') operation for any type--- implementing 'Generic'. This operation will append two values--- by point-wise appending their component fields. It is only defined--- for product types.------ @--- 'gmappend' a ('gmappend' b c) = 'gmappend' ('gmappend' a b) c--- @-gmappend :: (Generic a, GSemigroup (Rep a)) => a -> a -> a-gmappend x y = to (gmappend' (from x) (from y))--class GSemigroup f where-    gmappend' :: f p -> f p -> f p--instance Semigroup a => GSemigroup (K1 i a) where-    gmappend' (K1 x) (K1 y) = K1 (x <> y)--instance GSemigroup f => GSemigroup (M1 i c f) where-    gmappend' (M1 x) (M1 y) = M1 (gmappend' x y)--instance (GSemigroup f, GSemigroup g) => GSemigroup (f :*: g) where-    gmappend' (x1 :*: x2) (y1 :*: y2) = gmappend' x1 y1 :*: gmappend' x2 y2---- | Generically generate a 'Monoid' 'mempty' for any product-like type--- implementing 'Generic'.------ It is only defined for product types.------ @--- 'gmappend' 'gmempty' a = a = 'gmappend' a 'gmempty'--- @--gmempty :: (Generic a, GMonoid (Rep a)) => a-gmempty = to gmempty'--class GSemigroup f => GMonoid f where-    gmempty' :: f p--instance (Semigroup a, Monoid a) => GMonoid (K1 i a) where-    gmempty' = K1 mempty--instance GMonoid f => GMonoid (M1 i c f) where-    gmempty' = M1 gmempty'--instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where-    gmempty' = gmempty' :*: gmempty'
src/Distribution/Compat/SnocList.hs view
@@ -1,4 +1,5 @@ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Compat.SnocList -- License     :  BSD3@@ -8,14 +9,14 @@ -- Portability :  portable -- -- A very reversed list. Has efficient `snoc`-module Distribution.Compat.SnocList (-    SnocList,-    runSnocList,-    snoc,-) where+module Distribution.Compat.SnocList+  ( SnocList+  , runSnocList+  , snoc+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  newtype SnocList a = SnocList [a] @@ -26,8 +27,8 @@ runSnocList (SnocList xs) = reverse xs  instance Semigroup (SnocList a) where-    SnocList xs <> SnocList ys = SnocList (ys <> xs)+  SnocList xs <> SnocList ys = SnocList (ys <> xs)  instance Monoid (SnocList a) where-    mempty = SnocList []-    mappend = (<>)+  mempty = SnocList []+  mappend = (<>)
src/Distribution/Compat/Stack.hs view
@@ -1,102 +1,42 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ImplicitParams #-}-module Distribution.Compat.Stack (-    WithCallStack,-    CallStack,-    annotateCallStackIO,-    withFrozenCallStack,-    withLexicalCallStack,-    callStack,-    prettyCallStack,-    parentSrcLocPrefix-) where--import System.IO.Error+{-# LANGUAGE RankNTypes #-} -#ifdef MIN_VERSION_base-#if MIN_VERSION_base(4,8,1)-#define GHC_STACK_SUPPORTED 1-#endif-#endif+module Distribution.Compat.Stack+  ( WithCallStack+  , CallStack+  , annotateCallStackIO+  , withFrozenCallStack+  , withLexicalCallStack+  , callStack+  , prettyCallStack+  , parentSrcLocPrefix+  ) where -#ifdef GHC_STACK_SUPPORTED import GHC.Stack-#endif--#ifdef GHC_STACK_SUPPORTED+import System.IO.Error -#if MIN_VERSION_base(4,9,0) type WithCallStack a = HasCallStack => a-#elif MIN_VERSION_base(4,8,1)-type WithCallStack a = (?callStack :: CallStack) => a-#endif -#if !MIN_VERSION_base(4,9,0)--- NB: Can't say WithCallStack (WithCallStack a -> a);--- Haskell doesn't support this kind of implicit parameter!--- See https://mail.haskell.org/pipermail/ghc-devs/2016-January/011096.html--- Since this function doesn't do anything, it's OK to--- give it a less good type.-withFrozenCallStack :: WithCallStack (a -> a)-withFrozenCallStack x = x--callStack :: (?callStack :: CallStack) => CallStack-callStack = ?callStack--prettyCallStack :: CallStack -> String-prettyCallStack = showCallStack-#endif- -- | Give the *parent* of the person who invoked this; -- so it's most suitable for being called from a utility function. -- You probably want to call this using 'withFrozenCallStack'; otherwise -- it's not very useful.  We didn't implement this for base-4.8.1 -- because we cannot rely on freezing to have taken place.--- parentSrcLocPrefix :: WithCallStack String-#if MIN_VERSION_base(4,9,0) parentSrcLocPrefix =   case getCallStack callStack of-    (_:(_, loc):_) -> showLoc loc+    (_ : (_, loc) : _) -> showLoc loc     [(_, loc)] -> showLoc loc     [] -> error "parentSrcLocPrefix: empty call stack"- where-  showLoc loc =-    srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ": "-#else-parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): "-#endif+  where+    showLoc loc =+      srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ": "  -- Yeah, this uses skivvy implementation details. withLexicalCallStack :: (a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b) withLexicalCallStack f =-    let stk = ?callStack-    in \x -> let ?callStack = stk in f x--#else--data CallStack = CallStack-    deriving (Eq, Show)--type WithCallStack a = a--withFrozenCallStack :: a -> a-withFrozenCallStack x = x--callStack :: CallStack-callStack = CallStack--prettyCallStack :: CallStack -> String-prettyCallStack _ = "Call stacks not available with base < 4.8.1.0 (GHC 7.10)"--parentSrcLocPrefix :: String-parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): "--withLexicalCallStack :: (a -> IO b) -> a -> IO b-withLexicalCallStack f = f--#endif+  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@@ -106,8 +46,9 @@ annotateCallStackIO :: WithCallStack (IO a -> IO a) annotateCallStackIO = modifyIOError f   where-    f ioe = ioeSetErrorString ioe-          . wrapCallStack-          $ ioeGetErrorString ioe+    f ioe =+      ioeSetErrorString ioe+        . wrapCallStack+        $ ioeGetErrorString ioe     wrapCallStack s =-        prettyCallStack callStack ++ "\n" ++ s+      prettyCallStack callStack ++ "\n" ++ s
src/Distribution/Compat/Time.hs view
@@ -1,42 +1,39 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}  module Distribution.Compat.Time-       ( ModTime(..) -- Needed for testing-       , getModTime, getFileAge, getCurTime-       , posixSecondsToModTime-       , calibrateMtimeChangeDelay )-       where+  ( ModTime (..) -- Needed for testing+  , getModTime+  , getFileAge+  , getCurTime+  , posixSecondsToModTime+  , calibrateMtimeChangeDelay+  )+where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import System.Directory ( getModificationTime )+import System.Directory (getModificationTime) -import Distribution.Simple.Utils ( withTempDirectory )-import Distribution.Verbosity ( silent )+import Distribution.Simple.Utils (withTempDirectoryCwd)+import Distribution.Utils.Path (getSymbolicPath, sameDirectory)+import Distribution.Verbosity (silent)  import System.FilePath -import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime )-import Data.Time             ( diffUTCTime, getCurrentTime )-import Data.Time.Clock.POSIX ( posixDayLength )-+import Data.Time (diffUTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixDayLength)  #if defined mingw32_HOST_OS  import qualified Prelude import Data.Bits          ((.|.), unsafeShiftL)-#if MIN_VERSION_base(4,7,0) import Data.Bits          (finiteBitSize)-#else-import Data.Bits          (bitSize)-#endif  import Foreign            ( allocaBytes, peekByteOff ) import System.IO.Error    ( mkIOError, doesNotExistErrorType )@@ -44,20 +41,21 @@  #else -import System.Posix.Files ( FileStatus, getFileStatus )-+import System.Posix.Files+  ( FileStatus, getFileStatus #if MIN_VERSION_unix(2,6,0)-import System.Posix.Files ( modificationTimeHiRes )+  , modificationTimeHiRes #else-import System.Posix.Files ( modificationTime )+  , modificationTime #endif+  )  #endif  -- | An opaque type representing a file's modification time, represented -- internally as a 64-bit unsigned integer in the Windows UTC format. newtype ModTime = ModTime Word64-                deriving (Binary, Generic, Bounded, Eq, Ord, Typeable)+  deriving (Binary, Generic, Bounded, Eq, Ord)  instance Structured ModTime @@ -90,18 +88,13 @@                 index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime       dwHigh <- peekByteOff info                 index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime-#if MIN_VERSION_base(4,7,0)       let qwTime =             (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh)             .|. (fromIntegral (dwLow :: DWORD))-#else-      let qwTime =-            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh)-            .|. (fromIntegral (dwLow :: DWORD))-#endif       return $! ModTime (qwTime :: Word64) -#ifdef x86_64_HOST_ARCH+{- FOURMOLU_DISABLE -}+#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) #define CALLCONV ccall #else #define CALLCONV stdcall@@ -138,9 +131,10 @@ extractFileTime x = posixTimeToModTime (modificationTimeHiRes x)  #endif+{- FOURMOLU_ENABLE -}  windowsTick, secToUnixEpoch :: Word64-windowsTick    = 10000000+windowsTick = 10000000 secToUnixEpoch = 11644473600  -- | Convert POSIX seconds to ModTime.@@ -150,8 +144,10 @@  -- | Convert 'POSIXTime' to 'ModTime'. posixTimeToModTime :: POSIXTime -> ModTime-posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision-                       + (secToUnixEpoch * windowsTick)+posixTimeToModTime p =+  ModTime $+    ceiling (p * 1e7) -- 100 ns precision+      + (secToUnixEpoch * windowsTick)  -- | Return age of given file in days. getFileAge :: FilePath -> IO Double@@ -172,17 +168,17 @@ -- than 10 ms, but never larger than 1 second. calibrateMtimeChangeDelay :: IO (Int, Int) calibrateMtimeChangeDelay =-  withTempDirectory silent "." "calibration-" $ \dir -> do-    let fileName = dir </> "probe"-    mtimes <- for [1..25] $ \(i::Int) -> time $ do+  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)+            writeFile fileName $ show (i, j)             t1 <- getModTime fileName             unless (t0 < t1) (spin $ j + 1)-      spin (0::Int)-    let mtimeChange  = maximum mtimes+      spin (0 :: Int)+    let mtimeChange = maximum mtimes         mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2     return (mtimeChange, mtimeChange')   where
− src/Distribution/Compat/Typeable.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Compat.Typeable (-    Typeable,-    TypeRep,-    typeRep,-    ) where--#if MIN_VERSION_base(4,7,0)-import Data.Typeable (Typeable, TypeRep, typeRep)-#else-import Data.Typeable (Typeable, TypeRep, typeOf)-#endif--#if !MIN_VERSION_base(4,7,0)-typeRep :: forall a proxy. Typeable a => proxy a -> TypeRep-typeRep _ = typeOf (undefined :: a)-#endif
− src/Distribution/Compiler.hs 
@@ -1,223 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Compiler--- Copyright   :  Isaac Jones 2003-2004--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This has an enumeration of the various compilers that Cabal knows about. It--- also specifies the default compiler. Sadly you'll often see code that does--- case analysis on this compiler flavour enumeration like:------ > case compilerFlavor comp of--- >   GHC -> GHC.getInstalledPackages verbosity packageDb progdb------ Obviously it would be better to use the proper 'Compiler' abstraction--- because that would keep all the compiler-specific code together.--- Unfortunately we cannot make this change yet without breaking the--- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the--- moment we just have to live with this deficiency. If you're interested, see--- ticket #57.--module Distribution.Compiler (-  -- * Compiler flavor-  CompilerFlavor(..),-  buildCompilerId,-  buildCompilerFlavor,-  defaultCompilerFlavor,-  classifyCompilerFlavor,-  knownCompilerFlavors,--  -- * Per compiler flavor-  PerCompilerFlavor (..),-  perCompilerFlavorToList,--  -- * Compiler id-  CompilerId(..),--  -- * Compiler info-  CompilerInfo(..),-  unknownCompilerInfo,-  AbiTag(..), abiTagString-  ) where--import Prelude ()-import Distribution.Compat.Prelude--import Language.Haskell.Extension--import Distribution.Version (Version, mkVersion', nullVersion)--import qualified System.Info (compilerName, compilerVersion)-import Distribution.Parsec (Parsec (..))-import Distribution.Pretty (Pretty (..), prettyShow)-import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp--data CompilerFlavor =-  GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC | Eta-  | HaskellSuite String -- string is the id of the actual compiler-  | OtherCompiler String-  deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)--instance Binary CompilerFlavor-instance Structured CompilerFlavor-instance NFData CompilerFlavor where rnf = genericRnf--knownCompilerFlavors :: [CompilerFlavor]-knownCompilerFlavors =-  [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC, Eta]--instance Pretty CompilerFlavor where-  pretty (OtherCompiler name) = Disp.text name-  pretty (HaskellSuite name)  = Disp.text name-  pretty NHC                  = Disp.text "nhc98"-  pretty other                = Disp.text (lowercase (show other))--instance Parsec CompilerFlavor where-    parsec = classifyCompilerFlavor <$> component-      where-        component = do-          cs <- P.munch1 isAlphaNum-          if all isDigit cs then fail "all digits compiler name" else return cs--classifyCompilerFlavor :: String -> CompilerFlavor-classifyCompilerFlavor s =-  fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap-  where-    compilerMap = [ (lowercase (prettyShow compiler), compiler)-                  | compiler <- knownCompilerFlavors ]--buildCompilerFlavor :: CompilerFlavor-buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName--buildCompilerVersion :: Version-buildCompilerVersion = mkVersion' System.Info.compilerVersion--buildCompilerId :: CompilerId-buildCompilerId = CompilerId buildCompilerFlavor buildCompilerVersion---- | The default compiler flavour to pick when compiling stuff. This defaults--- to the compiler used to build the Cabal lib.------ However if it's not a recognised compiler then it's 'Nothing' and the user--- will have to specify which compiler they want.----defaultCompilerFlavor :: Maybe CompilerFlavor-defaultCompilerFlavor = case buildCompilerFlavor of-  OtherCompiler _ -> Nothing-  _               -> Just buildCompilerFlavor------------------------------------------------------------------------------------ Per compiler data------------------------------------------------------------------------------------ | 'PerCompilerFlavor' carries only info per GHC and GHCJS------ Cabal parses only @ghc-options@ and @ghcjs-options@, others are omitted.----data PerCompilerFlavor v = PerCompilerFlavor v v-  deriving (Generic, Show, Read, Eq, Typeable, Data, Functor, Foldable-           , Traversable)--instance Binary a => Binary (PerCompilerFlavor a)-instance Structured a => Structured (PerCompilerFlavor a)-instance NFData a => NFData (PerCompilerFlavor a)--perCompilerFlavorToList :: PerCompilerFlavor v -> [(CompilerFlavor, v)]-perCompilerFlavorToList (PerCompilerFlavor a b) = [(GHC, a), (GHCJS, b)]--instance Semigroup a => Semigroup (PerCompilerFlavor a) where-    PerCompilerFlavor a b <> PerCompilerFlavor a' b' = PerCompilerFlavor-        (a <> a') (b <> b')--instance (Semigroup a, Monoid a) => Monoid (PerCompilerFlavor a) where-    mempty = PerCompilerFlavor mempty mempty-    mappend = (<>)---- --------------------------------------------------------------- * Compiler Id--- --------------------------------------------------------------data CompilerId = CompilerId CompilerFlavor Version-  deriving (Eq, Generic, Ord, Read, Show, Typeable)--instance Binary CompilerId-instance Structured CompilerId-instance NFData CompilerId where rnf = genericRnf--instance Pretty CompilerId where-  pretty (CompilerId f v)-    | v == nullVersion = pretty f-    | otherwise        = pretty f <<>> Disp.char '-' <<>> pretty v--instance Parsec CompilerId where-  parsec = do-    flavour <- parsec-    version <- (P.char '-' >> parsec) <|> return nullVersion-    return (CompilerId flavour version)--lowercase :: String -> String-lowercase = map toLower---- --------------------------------------------------------------- * Compiler Info--- ---------------------------------------------------------------- | Compiler information used for resolving configurations. Some---   fields can be set to Nothing to indicate that the information is---   unknown.--data CompilerInfo = CompilerInfo {-         compilerInfoId         :: CompilerId,-         -- ^ Compiler flavour and version.-         compilerInfoAbiTag     :: AbiTag,-         -- ^ Tag for distinguishing incompatible ABI's on the same-         -- architecture/os.-         compilerInfoCompat     :: Maybe [CompilerId],-         -- ^ Other implementations that this compiler claims to be-         -- compatible with, if known.-         compilerInfoLanguages  :: Maybe [Language],-         -- ^ Supported language standards, if known.-         compilerInfoExtensions :: Maybe [Extension]-         -- ^ Supported extensions, if known.-     }-     deriving (Generic, Show, Read)--instance Binary CompilerInfo--data AbiTag-  = NoAbiTag-  | AbiTag String-  deriving (Eq, Generic, Show, Read, Typeable)--instance Binary AbiTag-instance Structured AbiTag--instance Pretty AbiTag where-  pretty NoAbiTag     = Disp.empty-  pretty (AbiTag tag) = Disp.text tag--instance Parsec AbiTag where-  parsec = do-    tag <- P.munch (\c -> isAlphaNum c || c == '_')-    if null tag then return NoAbiTag else return (AbiTag tag)--abiTagString :: AbiTag -> String-abiTagString NoAbiTag     = ""-abiTagString (AbiTag tag) = tag---- | Make a CompilerInfo of which only the known information is its CompilerId,---   its AbiTag and that it does not claim to be compatible with other---   compiler id's.-unknownCompilerInfo :: CompilerId -> AbiTag -> CompilerInfo-unknownCompilerInfo compilerId abiTag =-  CompilerInfo compilerId abiTag (Just []) Nothing Nothing
− src/Distribution/FieldGrammar.hs 
@@ -1,88 +0,0 @@-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | This module provides a way to specify a grammar of @.cabal@ -like files.-module Distribution.FieldGrammar  (-    -- * Field grammar type-    FieldGrammar (..),-    uniqueField,-    optionalField,-    optionalFieldDef,-    monoidalField,-    -- * Concrete grammar implementations-    ParsecFieldGrammar,-    ParsecFieldGrammar',-    parseFieldGrammar,-    fieldGrammarKnownFieldList,-    PrettyFieldGrammar,-    PrettyFieldGrammar',-    prettyFieldGrammar,-    -- * Auxlilary-    (^^^),-    Section(..),-    Fields,-    partitionFields,-    takeFields,-    runFieldParser,-    runFieldParser',-    defaultFreeTextFieldDefST,-    -- * Newtypes-    module Distribution.FieldGrammar.Newtypes,-    )  where--import Distribution.Compat.Prelude-import Prelude ()--import qualified Data.Map.Strict as Map--import Distribution.FieldGrammar.Class-import Distribution.FieldGrammar.Newtypes-import Distribution.FieldGrammar.Parsec-import Distribution.FieldGrammar.Pretty-import Distribution.Fields.Field-import Distribution.Utils.Generic         (spanMaybe)--type ParsecFieldGrammar' a = ParsecFieldGrammar a a-type PrettyFieldGrammar' a = PrettyFieldGrammar a a--infixl 5 ^^^---- | Reverse function application which binds tighter than '<$>' and '<*>'.--- Useful for refining grammar specification.------ @--- \<*\> 'monoidalFieldAla' "extensions"           (alaList' FSep MQuoted)       oldExtensions---     ^^^ 'deprecatedSince' [1,12] "Please use 'default-extensions' or 'other-extensions' fields."--- @-(^^^) :: a -> (a -> b) -> b-x ^^^ f = f x---- | Partitioning state-data PS ann = PS (Fields ann) [Section ann] [[Section ann]]---- | Partition field list into field map and groups of sections.-partitionFields :: [Field ann] -> (Fields ann, [[Section ann]])-partitionFields = finalize . foldl' f (PS mempty mempty mempty)-  where-    finalize :: PS ann -> (Fields ann, [[Section ann]])-    finalize (PS fs s ss)-        | null s    = (fs, reverse ss)-        | otherwise = (fs, reverse (reverse s : ss))--    f :: PS ann -> Field ann -> PS ann-    f (PS fs s ss) (Field (Name ann name) fss) =-        PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss'-      where-        ss' | null s    = ss-            | otherwise = reverse s : ss-    f (PS fs s ss) (Section name sargs sfields) =-        PS fs (MkSection name sargs sfields : s) ss---- | Take all fields from the front.-takeFields :: [Field ann] -> (Fields ann, [Field ann])-takeFields = finalize . spanMaybe match-  where-    finalize (fs, rest) = (Map.fromListWith (flip (++)) fs, rest)--    match (Field (Name ann name) fs) = Just (name, [MkNamelessField ann fs])-    match _ = Nothing
− src/Distribution/FieldGrammar/Class.hs 
@@ -1,205 +0,0 @@-{-# LANGUAGE CPP                     #-}-{-# LANGUAGE ConstraintKinds         #-}-{-# LANGUAGE FunctionalDependencies  #-}-{-# LANGUAGE RankNTypes              #-}-{-# LANGUAGE ScopedTypeVariables     #-}-#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE UndecidableSuperClasses #-}-#else-{-# LANGUAGE UndecidableInstances #-}-#endif-module Distribution.FieldGrammar.Class (-    FieldGrammar (..),-    uniqueField,-    optionalField,-    optionalFieldDef,-    monoidalField,-    defaultFreeTextFieldDefST,-) where--import Distribution.Compat.Lens-import Distribution.Compat.Prelude-import Prelude ()--import Distribution.CabalSpecVersion      (CabalSpecVersion)-import Distribution.Compat.Newtype        (Newtype)-import Distribution.FieldGrammar.Newtypes-import Distribution.Fields.Field-import Distribution.Utils.ShortText---- | 'FieldGrammar' is parametrised by------ * @s@ which is a structure we are parsing. We need this to provide prettyprinter--- functionality------ * @a@ type of the field.------ /Note:/ We'd like to have @forall s. Applicative (f s)@ context.----class-    ( c SpecVersion, c TestedWith, c SpecLicense, c Token, c Token', c FilePathNT-    )-    => FieldGrammar c g | g -> c-  where-    -- | Unfocus, zoom out, /blur/ 'FieldGrammar'.-    blurFieldGrammar :: ALens' a b -> g b d -> g a d--    -- | Field which should be defined, exactly once.-    uniqueFieldAla-        :: (c b, Newtype a b)-        => FieldName   -- ^ field name-        -> (a -> b)    -- ^ 'Newtype' pack-        -> ALens' s a  -- ^ lens into the field-        -> g s a--    -- | Boolean field with a default value.-    booleanFieldDef-        :: FieldName     -- ^ field name-        -> ALens' s Bool -- ^ lens into the field-        -> Bool          -- ^ default-        -> g s Bool--    -- | Optional field.-    optionalFieldAla-        :: (c b, Newtype a b)-        => FieldName          -- ^ field name-        -> (a -> b)           -- ^ 'pack'-        -> ALens' s (Maybe a) -- ^ lens into the field-        -> g s (Maybe a)--    -- | Optional field with default value.-    optionalFieldDefAla-        :: (c b, Newtype a b, Eq a)-        => FieldName   -- ^ field name-        -> (a -> b)    -- ^ 'Newtype' pack-        -> ALens' s a  -- ^ @'Lens'' s a@: lens into the field-        -> a           -- ^ default value-        -> g s a--    --  | Free text field is essentially 'optionalFieldDefAla` with @""@-    --  as the default and "accept everything" parser.-    ---    -- @since 3.0.0.0-    freeTextField-        :: FieldName-        -> ALens' s (Maybe String) -- ^ lens into the field-        -> g s (Maybe String)--    --  | Free text field is essentially 'optionalFieldDefAla` with @""@-    --  as the default and "accept everything" parser.-    ---    -- @since 3.0.0.0-    freeTextFieldDef-        :: FieldName-        -> ALens' s String -- ^ lens into the field-        -> g s String--    -- | @since 3.2.0.0-    freeTextFieldDefST-        :: FieldName-        -> ALens' s ShortText -- ^ lens into the field-        -> g s ShortText--    -- | Monoidal field.-    ---    -- Values are combined with 'mappend'.-    ---    -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid.-    ---    monoidalFieldAla-        :: (c b, Monoid a, Newtype a b)-        => FieldName   -- ^ field name-        -> (a -> b)    -- ^ 'pack'-        -> ALens' s a  -- ^ lens into the field-        -> g s a--    -- | Parser matching all fields with a name starting with a prefix.-    prefixedFields-        :: FieldName                    -- ^ field name prefix-        -> ALens' s [(String, String)]  -- ^ lens into the field-        -> g s [(String, String)]--    -- | Known field, which we don't parse, nor pretty print.-    knownField :: FieldName -> g s ()--    -- | Field which is parsed but not pretty printed.-    hiddenField :: g s a -> g s a--    -- | Deprecated since-    deprecatedSince-        :: CabalSpecVersion   -- ^ version-        -> String             -- ^ deprecation message-        -> g s a-        -> g s a--    -- | Removed in. If we encounter removed field, parsing fails.-    removedIn-        :: CabalSpecVersion   -- ^ version-        -> String             -- ^ removal message-        -> g s a-        -> g s a--    -- | Annotate field with since spec-version.-    availableSince-        :: CabalSpecVersion  -- ^ spec version-        -> a                 -- ^ default value-        -> g s a-        -> g s a--    -- | Annotate field with since spec-version.-    -- This is used to recognise, but warn about the field.-    -- It is used to process @other-extensions@ field.-    ---    -- Default implementation is to not warn.-    ---    -- @since 3.4.0.0-    availableSinceWarn-        :: CabalSpecVersion  -- ^ spec version-        -> g s a-        -> g s a-    availableSinceWarn _ = id---- | Field which can be defined at most once.-uniqueField-    :: (FieldGrammar c g, c (Identity a))-    => FieldName   -- ^ field name-    -> ALens' s a  -- ^ lens into the field-    -> g s a-uniqueField fn l = uniqueFieldAla fn Identity l---- | Field which can be defined at most once.-optionalField-    :: (FieldGrammar c g, c (Identity a))-    => FieldName          -- ^ field name-    -> ALens' s (Maybe a) -- ^ lens into the field-    -> g s (Maybe a)-optionalField fn l = optionalFieldAla fn Identity l---- | Optional field with default value.-optionalFieldDef-    :: (FieldGrammar c g, Functor (g s), c (Identity a), Eq a)-    => FieldName   -- ^ field name-    -> ALens' s a  -- ^ @'Lens'' s a@: lens into the field-    -> a           -- ^ default value-    -> g s a-optionalFieldDef fn l x = optionalFieldDefAla fn Identity l x---- | Field which can be define multiple times, and the results are @mappend@ed.-monoidalField-    :: (FieldGrammar c g, c (Identity a), Monoid a)-    => FieldName   -- ^ field name-    -> ALens' s a  -- ^ lens into the field-    -> g s a-monoidalField fn l = monoidalFieldAla fn Identity l---- | Default implementation for 'freeTextFieldDefST'.-defaultFreeTextFieldDefST-    :: (Functor (g s), FieldGrammar c g)-    => FieldName-    -> ALens' s ShortText -- ^ lens into the field-    -> g s ShortText-defaultFreeTextFieldDefST fn l =-    toShortText <$> freeTextFieldDef fn (cloneLens l . st)-  where-    st :: Lens' ShortText String-    st f s = toShortText <$> f (fromShortText s)
− src/Distribution/FieldGrammar/FieldDescrs.hs 
@@ -1,121 +0,0 @@-{-# LANGUAGE DeriveFunctor         #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE UndecidableInstances  #-}-module Distribution.FieldGrammar.FieldDescrs (-    FieldDescrs,-    fieldDescrPretty,-    fieldDescrParse,-    fieldDescrsToList,-    ) where--import Distribution.Compat.Prelude-import Prelude ()--import Data.List                   (dropWhileEnd)-import Distribution.Compat.Lens    (aview, cloneLens)-import Distribution.Compat.Newtype-import Distribution.FieldGrammar-import Distribution.Pretty         (Pretty (..), showFreeText)--import qualified Data.Map                        as Map-import qualified Distribution.Compat.CharParsing as C-import qualified Distribution.Fields.Field       as P-import qualified Distribution.Parsec             as P-import qualified Text.PrettyPrint                as Disp---- strict pair-data SP s = SP-    { pPretty :: !(s -> Disp.Doc)-    , pParse  :: !(forall m. P.CabalParsing m => s -> m s)-    }---- | A collection of field parsers and pretty-printers.-newtype FieldDescrs s a = F { runF :: Map P.FieldName (SP s) }-  deriving (Functor)--instance Applicative (FieldDescrs s) where-    pure _  = F mempty-    f <*> x = F (mappend (runF f) (runF x))--singletonF :: P.FieldName -> (s -> Disp.Doc) -> (forall m. P.CabalParsing m => s -> m s) -> FieldDescrs s a-singletonF fn f g = F $ Map.singleton fn (SP f g)---- | Lookup a field value pretty-printer.-fieldDescrPretty :: FieldDescrs s a -> P.FieldName -> Maybe (s -> Disp.Doc)-fieldDescrPretty (F m) fn = pPretty <$> Map.lookup fn m---- | Lookup a field value parser.-fieldDescrParse :: P.CabalParsing m => FieldDescrs s a -> P.FieldName -> Maybe (s -> m s)-fieldDescrParse (F m) fn = (\f -> pParse f) <$> Map.lookup fn m--fieldDescrsToList-    :: P.CabalParsing m-    => FieldDescrs s a-    -> [(P.FieldName, s -> Disp.Doc, s -> m s)]-fieldDescrsToList = map mk . Map.toList . runF where-    mk (name, SP ppr parse) = (name, ppr, parse)---- | /Note:/ default values are printed.-instance FieldGrammar ParsecPretty FieldDescrs where-    blurFieldGrammar l (F m) = F (fmap blur m) where-        blur (SP f g) = SP (f . aview l) (cloneLens l g)--    booleanFieldDef fn l _def = singletonF fn f g where-        f s = Disp.text (show (aview l s))-        g s = cloneLens l (const P.parsec) s-      -- Note: eta expansion is needed for RankNTypes type-checking to work.--    uniqueFieldAla fn _pack l = singletonF fn f g where-        f s = pretty (pack' _pack (aview l s))-        g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s--    optionalFieldAla fn _pack l = singletonF fn f g where-        f s = maybe mempty (pretty . pack' _pack) (aview l s)-        g s = cloneLens l (const (Just . unpack' _pack <$> P.parsec)) s--    optionalFieldDefAla fn _pack l _def = singletonF fn f g where-        f s = pretty (pack' _pack (aview l s))-        g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s--    freeTextField fn l = singletonF fn f g where-        f s = maybe mempty showFreeText (aview l s)-        g s = cloneLens l (const (Just <$> parsecFreeText)) s--    freeTextFieldDef fn l = singletonF fn f g where-        f s = showFreeText (aview l s)-        g s = cloneLens l (const parsecFreeText) s--    freeTextFieldDefST = defaultFreeTextFieldDefST--    monoidalFieldAla fn _pack l = singletonF fn f g where-        f s = pretty (pack' _pack (aview l s))-        g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s--    prefixedFields _fnPfx _l = F mempty-    knownField _           = pure ()-    deprecatedSince _  _ x = x-    removedIn _ _ x        = x-    availableSince _ _     = id-    hiddenField _          = F mempty--parsecFreeText :: P.CabalParsing m => m String-parsecFreeText = dropDotLines <$ C.spaces <*> many C.anyChar-  where-    -- Example package with dot lines-    -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal-    dropDotLines "." = "."-    dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x--    dotToEmpty x | trim' x == "." = ""-    dotToEmpty x                  = trim x--    trim' :: String -> String-    trim' = dropWhileEnd (`elem` (" \t" :: String))--    trim :: String -> String-    trim = dropWhile isSpace . dropWhileEnd isSpace--class    (P.Parsec a, Pretty a) => ParsecPretty a-instance (P.Parsec a, Pretty a) => ParsecPretty a
− src/Distribution/FieldGrammar/Newtypes.hs 
@@ -1,392 +0,0 @@-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE OverloadedStrings      #-}-{-# LANGUAGE RankNTypes             #-}-{-# LANGUAGE ScopedTypeVariables    #-}--- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar".-module Distribution.FieldGrammar.Newtypes (-    -- * List-    alaList,-    alaList',-    -- ** Modifiers-    CommaVCat (..),-    CommaFSep (..),-    VCat (..),-    FSep (..),-    NoCommaFSep (..),-    Sep (..),-    -- ** Type-    List,-    -- ** Set-    alaSet,-    alaSet',-    Set',-    -- ** NonEmpty-    alaNonEmpty,-    alaNonEmpty',-    NonEmpty',-    -- * Version & License-    SpecVersion (..),-    TestedWith (..),-    SpecLicense (..),-    -- * Identifiers-    Token (..),-    Token' (..),-    MQuoted (..),-    FilePathNT (..),-    ) where--import Distribution.Compat.Newtype-import Distribution.Compat.Prelude-import Prelude ()--import Distribution.CabalSpecVersion-import Distribution.Compiler         (CompilerFlavor)-import Distribution.License          (License)-import Distribution.Parsec-import Distribution.Pretty-import Distribution.Version-       (LowerBound (..), Version, VersionInterval (..), VersionRange, VersionRangeF (..), anyVersion, asVersionIntervals, cataVersionRange, mkVersion,-       version0, versionNumbers)-import Text.PrettyPrint              (Doc, comma, fsep, punctuate, text, vcat)--import qualified Data.List.NonEmpty              as NE-import qualified Data.Set                        as Set-import qualified Distribution.Compat.CharParsing as P-import qualified Distribution.SPDX               as SPDX---- | Vertical list with commas. Displayed with 'vcat'-data CommaVCat = CommaVCat---- | Paragraph fill list with commas. Displayed with 'fsep'-data CommaFSep = CommaFSep---- | Vertical list with optional commas. Displayed with 'vcat'.-data VCat = VCat---- | Paragraph fill list with optional commas. Displayed with 'fsep'.-data FSep = FSep---- | Paragraph fill list without commas. Displayed with 'fsep'.-data NoCommaFSep = NoCommaFSep--class    Sep sep  where-    prettySep :: Proxy sep -> [Doc] -> Doc--    parseSep   :: CabalParsing m => Proxy sep -> m a -> m [a]-    parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty a)--instance Sep CommaVCat where-    prettySep  _ = vcat . punctuate comma-    parseSep   _ p = do-        v <- askCabalSpecVersion-        if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p-    parseSepNE _ p = do-        v <- askCabalSpecVersion-        if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p-instance Sep CommaFSep where-    prettySep _ = fsep . punctuate comma-    parseSep   _ p = do-        v <- askCabalSpecVersion-        if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p-    parseSepNE _ p = do-        v <- askCabalSpecVersion-        if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p-instance Sep VCat where-    prettySep _  = vcat-    parseSep   _ p = do-        v <- askCabalSpecVersion-        if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p-    parseSepNE _ p = NE.some1 (p <* P.spaces)-instance Sep FSep where-    prettySep _  = fsep-    parseSep   _ p = do-        v <- askCabalSpecVersion-        if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p-    parseSepNE _ p = NE.some1 (p <* P.spaces)-instance Sep NoCommaFSep where-    prettySep _    = fsep-    parseSep  _ p  = many (p <* P.spaces)-    parseSepNE _ p = NE.some1 (p <* P.spaces)---- | List separated with optional commas. Displayed with @sep@, arguments of--- type @a@ are parsed and pretty-printed as @b@.-newtype List sep b a = List { _getList :: [a] }---- | 'alaList' and 'alaList'' are simply 'List', with additional phantom--- arguments to constrain the resulting type------ >>> :t alaList VCat--- alaList VCat :: [a] -> List VCat (Identity a) a------ >>> :t alaList' FSep Token--- alaList' FSep Token :: [String] -> List FSep Token String----alaList :: sep -> [a] -> List sep (Identity a) a-alaList _ = List---- | More general version of 'alaList'.-alaList' :: sep -> (a -> b) -> [a] -> List sep b a-alaList' _ _ = List--instance Newtype [a] (List sep wrapper a)--instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where-    parsec   = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec--instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where-    pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack------- | Like 'List', but for 'Set'.------ @since 3.2.0.0-newtype Set' sep b a = Set' { _getSet :: Set a }---- | 'alaSet' and 'alaSet'' are simply 'Set'' constructor, with additional phantom--- arguments to constrain the resulting type------ >>> :t alaSet VCat--- alaSet VCat :: Set a -> Set' VCat (Identity a) a------ >>> :t alaSet' FSep Token--- alaSet' FSep Token :: Set String -> Set' FSep Token String------ >>> unpack' (alaSet' FSep Token) <$> eitherParsec "foo bar foo"--- Right (fromList ["bar","foo"])------ @since 3.2.0.0-alaSet :: sep -> Set a -> Set' sep (Identity a) a-alaSet _ = Set'---- | More general version of 'alaSet'.------ @since 3.2.0.0-alaSet' :: sep -> (a -> b) -> Set a -> Set' sep b a-alaSet' _ _ = Set'--instance Newtype (Set a) (Set' sep wrapper a)--instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (Set' sep b a) where-    parsec   = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec--instance (Newtype a b, Sep sep, Pretty b) => Pretty (Set' sep b a) where-    pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack------- | Like 'List', but for 'NonEmpty'.------ @since 3.2.0.0-newtype NonEmpty' sep b a = NonEmpty' { _getNonEmpty :: NonEmpty a }---- | 'alaNonEmpty' and 'alaNonEmpty'' are simply 'NonEmpty'' constructor, with additional phantom--- arguments to constrain the resulting type------ >>> :t alaNonEmpty VCat--- alaNonEmpty VCat :: NonEmpty a -> NonEmpty' VCat (Identity a) a------ >>> unpack' (alaNonEmpty' FSep Token) <$> eitherParsec "foo bar foo"--- Right ("foo" :| ["bar","foo"])------ @since 3.2.0.0-alaNonEmpty :: sep -> NonEmpty a -> NonEmpty' sep (Identity a) a-alaNonEmpty _ = NonEmpty'---- | More general version of 'alaNonEmpty'.------ @since 3.2.0.0-alaNonEmpty' :: sep -> (a -> b) -> NonEmpty a -> NonEmpty' sep b a-alaNonEmpty' _ _ = NonEmpty'--instance Newtype (NonEmpty a) (NonEmpty' sep wrapper a)--instance (Newtype a b, Sep sep, Parsec b) => Parsec (NonEmpty' sep b a) where-    parsec   = pack . fmap (unpack :: b -> a) <$> parseSepNE (Proxy :: Proxy sep) parsec--instance (Newtype a b, Sep sep, Pretty b) => Pretty (NonEmpty' sep b a) where-    pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NE.toList . unpack------------------------------------------------------------------------------------ Identifiers------------------------------------------------------------------------------------ | Haskell string or @[^ ,]+@-newtype Token = Token { getToken :: String }--instance Newtype String Token--instance Parsec Token where-    parsec = pack <$> parsecToken--instance Pretty Token where-    pretty = showToken . unpack---- | Haskell string or @[^ ]+@-newtype Token' = Token' { getToken' :: String }--instance Newtype String Token'--instance Parsec Token' where-    parsec = pack <$> parsecToken'--instance Pretty Token' where-    pretty = showToken . unpack---- | Either @"quoted"@ or @un-quoted@.-newtype MQuoted a = MQuoted { getMQuoted :: a }--instance Newtype a (MQuoted a)--instance Parsec a => Parsec (MQuoted a) where-    parsec = pack <$> parsecMaybeQuoted parsec--instance Pretty a => Pretty (MQuoted a)  where-    pretty = pretty . unpack---- | Filepath are parsed as 'Token'.-newtype FilePathNT = FilePathNT { getFilePathNT :: String }--instance Newtype String FilePathNT--instance Parsec FilePathNT where-    parsec = do-        token <- parsecToken-        if null token-        then P.unexpected "empty FilePath"-        else return (FilePathNT token)--instance Pretty FilePathNT where-    pretty = showFilePath . unpack------------------------------------------------------------------------------------ SpecVersion------------------------------------------------------------------------------------ | Version range or just version, i.e. @cabal-version@ field.------ There are few things to consider:------ * Starting with 2.2 the cabal-version field should be the first field in the---   file and only exact version is accepted. Therefore if we get e.g.---   @>= 2.2@, we fail.---   See <https://github.com/haskell/cabal/issues/4899>------ We have this newtype, as writing Parsec and Pretty instances--- for CabalSpecVersion would cause cycle in modules:---     Version -> CabalSpecVersion -> Parsec -> ...----newtype SpecVersion = SpecVersion { getSpecVersion :: CabalSpecVersion }-  deriving (Eq, Show) -- instances needed for tests--instance Newtype CabalSpecVersion SpecVersion--instance Parsec SpecVersion where-    parsec = do-        e <- parsecSpecVersion-        let ver    :: Version-            ver    = either id specVersionFromRange e--            digits :: [Int]-            digits = versionNumbers ver--        case cabalSpecFromVersionDigits digits of-            Nothing  -> fail $ "Unknown cabal spec version specified: " ++ prettyShow ver-            Just csv -> do-                -- Check some warnings:-                case e of-                    -- example:   cabal-version: 1.10-                    -- should be  cabal-version: >=1.10-                    Left _v | csv < CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat-                        [ "With 1.10 or earlier, the 'cabal-version' field must use "-                        , "range syntax rather than a simple version number. Use "-                        , "'cabal-version: >= " ++ prettyShow ver ++ "'."-                        ]--                    -- example:   cabal-version: >=1.12-                    -- should be  cabal-version: 1.12-                    Right _vr | csv >= CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat-                        [ "Packages with 'cabal-version: 1.12' or later should specify a "-                        , "specific version of the Cabal spec of the form "-                        , "'cabal-version: x.y'. "-                        , "Use 'cabal-version: " ++ prettyShow ver ++ "'."-                        ]--                    -- example:   cabal-version: >=1.10 && <1.12-                    -- should be  cabal-version: >=1.10-                    Right vr | csv < CabalSpecV1_12-                            , not (simpleSpecVersionRangeSyntax vr) -> parsecWarning PWTSpecVersion $ concat-                        [ "It is recommended that the 'cabal-version' field only specify a "-                        , "version range of the form '>= x.y' for older cabal versions. Use "-                        , "'cabal-version: >= " ++ prettyShow ver ++ "'. "-                        , "Tools based on Cabal 1.10 and later will ignore upper bounds."-                        ]--                    -- otherwise no warnings-                    _ -> pure ()--                return (pack csv)-      where-        parsecSpecVersion = Left <$> parsec <|> Right <$> range--        range = do-            vr <- parsec-            if specVersionFromRange vr >= mkVersion [2,1]-            then fail "cabal-version higher than 2.2 cannot be specified as a range. See https://github.com/haskell/cabal/issues/4899"-            else return vr--        specVersionFromRange :: VersionRange -> Version-        specVersionFromRange versionRange = case asVersionIntervals versionRange of-            []                                           -> version0-            VersionInterval (LowerBound version _) _ : _ -> version--        simpleSpecVersionRangeSyntax = cataVersionRange alg where-            alg (OrLaterVersionF _) = True-            alg _                   = False---instance Pretty SpecVersion where-    pretty (SpecVersion csv)-        | csv >= CabalSpecV1_12 = text (showCabalSpecVersion csv)-        | otherwise             = text ">=" <<>> text (showCabalSpecVersion csv)------------------------------------------------------------------------------------ SpecLicense------------------------------------------------------------------------------------ | SPDX License expression or legacy license-newtype SpecLicense = SpecLicense { getSpecLicense :: Either SPDX.License License }--instance Newtype (Either SPDX.License License) SpecLicense--instance Parsec SpecLicense where-    parsec = do-        v <- askCabalSpecVersion-        if v >= CabalSpecV2_2-        then SpecLicense . Left <$> parsec-        else SpecLicense . Right <$> parsec--instance Pretty SpecLicense where-    pretty = either pretty pretty . unpack------------------------------------------------------------------------------------ TestedWith------------------------------------------------------------------------------------ | Version range or just version-newtype TestedWith = TestedWith { getTestedWith :: (CompilerFlavor, VersionRange) }--instance Newtype (CompilerFlavor, VersionRange) TestedWith--instance Parsec TestedWith where-    parsec = pack <$> parsecTestedWith--instance Pretty TestedWith where-    pretty x = case unpack x of-        (compiler, vr) -> pretty compiler <+> pretty vr--parsecTestedWith :: CabalParsing m => m (CompilerFlavor, VersionRange)-parsecTestedWith = do-    name <- lexemeParsec-    ver  <- parsec <|> pure anyVersion-    return (name, ver)
− src/Distribution/FieldGrammar/Parsec.hs 
@@ -1,439 +0,0 @@-{-# LANGUAGE DeriveFunctor         #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE ScopedTypeVariables   #-}--- | This module provides a 'FieldGrammarParser', one way to parse--- @.cabal@ -like files.------ Fields can be specified multiple times in the .cabal files.  The order of--- such entries is important, but the mutual ordering of different fields is--- not.Also conditional sections are considered after non-conditional data.--- The example of this silent-commutation quirk is the fact that------ @--- buildable: True--- if os(linux)---   buildable: False--- @------ and------ @--- if os(linux)---   buildable: False--- buildable: True--- @------ behave the same! This is the limitation of 'GeneralPackageDescription'--- structure.------ So we transform the list of fields @['Field' ann]@ into--- a map of grouped ordinary fields and a list of lists of sections:--- @'Fields' ann = 'Map' 'FieldName' ['NamelessField' ann]@ and @[['Section' ann]]@.------ We need list of list of sections, because we need to distinguish situations--- where there are fields in between. For example------ @--- if flag(bytestring-lt-0_10_4)---   build-depends: bytestring < 0.10.4------ default-language: Haskell2020------ else---   build-depends: bytestring >= 0.10.4------ @------ is obviously invalid specification.------ We can parse 'Fields' like we parse @aeson@ objects, yet we use--- slightly higher-level API, so we can process unspecified fields,--- to report unknown fields and save custom @x-fields@.----module Distribution.FieldGrammar.Parsec (-    ParsecFieldGrammar,-    parseFieldGrammar,-    fieldGrammarKnownFieldList,-    -- * Auxiliary-    Fields,-    NamelessField (..),-    namelessFieldAnn,-    Section (..),-    runFieldParser,-    runFieldParser',-    fieldLinesToStream,-    )  where--import Data.List                   (dropWhileEnd)-import Distribution.Compat.Newtype-import Distribution.Compat.Prelude-import Distribution.Simple.Utils   (fromUTF8BS)-import Prelude ()--import qualified Data.ByteString              as BS-import qualified Data.List.NonEmpty           as NE-import qualified Data.Map.Strict              as Map-import qualified Data.Set                     as Set-import qualified Distribution.Utils.ShortText as ShortText-import qualified Text.Parsec                  as P-import qualified Text.Parsec.Error            as P--import Distribution.CabalSpecVersion-import Distribution.FieldGrammar.Class-import Distribution.Fields.Field-import Distribution.Fields.ParseResult-import Distribution.Parsec-import Distribution.Parsec.FieldLineStream-import Distribution.Parsec.Position        (positionCol, positionRow)------------------------------------------------------------------------------------ Auxiliary types----------------------------------------------------------------------------------type Fields ann = Map FieldName [NamelessField ann]---- | Single field, without name, but with its annotation.-data NamelessField ann = MkNamelessField !ann [FieldLine ann]-  deriving (Eq, Show, Functor)--namelessFieldAnn :: NamelessField ann -> ann-namelessFieldAnn (MkNamelessField ann _) = ann---- | The 'Section' constructor of 'Field'.-data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann]-  deriving (Eq, Show, Functor)------------------------------------------------------------------------------------ ParsecFieldGrammar----------------------------------------------------------------------------------data ParsecFieldGrammar s a = ParsecFG-    { fieldGrammarKnownFields   :: !(Set FieldName)-    , fieldGrammarKnownPrefixes :: !(Set FieldName)-    , fieldGrammarParser        :: !(CabalSpecVersion -> Fields Position -> ParseResult a)-    }-  deriving (Functor)--parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult a-parseFieldGrammar v fields grammar = do-    for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) ->-        for_ nfields $ \(MkNamelessField pos _) ->-            parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name-            -- TODO: fields allowed in this section--    -- parse-    fieldGrammarParser grammar v fields--  where-    isUnknownField k _ = not $-        k `Set.member` fieldGrammarKnownFields grammar-        || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar)--fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName]-fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields--instance Applicative (ParsecFieldGrammar s) where-    pure x = ParsecFG mempty mempty (\_ _  -> pure x)-    {-# INLINE pure  #-}--    ParsecFG f f' f'' <*> ParsecFG x x' x'' = ParsecFG-        (mappend f x)-        (mappend f' x')-        (\v fields -> f'' v fields <*> x'' v fields)-    {-# INLINE (<*>) #-}--warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult ()-warnMultipleSingularFields _ [] = pure ()-warnMultipleSingularFields fn (x : xs) = do-    let pos  = namelessFieldAnn x-        poss = map namelessFieldAnn xs-    parseWarning pos PWTMultipleSingularField $-        "The field " <> show fn <> " is specified more than once at positions " ++ intercalate ", " (map showPos (pos : poss))--instance FieldGrammar Parsec ParsecFieldGrammar where-    blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser--    uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser-      where-        parser v fields = case Map.lookup fn fields of-            Nothing          -> parseFatalFailure zeroPos $ show fn ++ " field missing"-            Just []          -> parseFatalFailure zeroPos $ show fn ++ " field missing"-            Just [x]         -> parseOne v x-            Just xs@(_:y:ys) -> do-                warnMultipleSingularFields fn xs-                NE.last <$> traverse (parseOne v) (y:|ys)--        parseOne v (MkNamelessField pos fls) =-            unpack' _pack <$> runFieldParser pos parsec v fls--    booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser-      where-        parser v fields = case Map.lookup fn fields of-            Nothing          -> pure def-            Just []          -> pure def-            Just [x]         -> parseOne v x-            Just xs@(_:y:ys) -> do-                warnMultipleSingularFields fn xs-                NE.last <$> traverse (parseOne v) (y:|ys)--        parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls--    optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser-      where-        parser v fields = case Map.lookup fn fields of-            Nothing          -> pure Nothing-            Just []          -> pure Nothing-            Just [x]         -> parseOne v x-            Just xs@(_:y:ys) -> do-                warnMultipleSingularFields fn xs-                NE.last <$> traverse (parseOne v) (y:|ys)--        parseOne v (MkNamelessField pos fls)-            | null fls  = pure Nothing-            | otherwise = Just . unpack' _pack <$> runFieldParser pos parsec v fls--    optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser-      where-        parser v fields = case Map.lookup fn fields of-            Nothing          -> pure def-            Just []          -> pure def-            Just [x]         -> parseOne v x-            Just xs@(_:y:ys) -> do-                warnMultipleSingularFields fn xs-                NE.last <$> traverse (parseOne v) (y:|ys)--        parseOne v (MkNamelessField pos fls)-            | null fls  = pure def-            | otherwise = unpack' _pack <$> runFieldParser pos parsec v fls--    freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser where-        parser v fields = case Map.lookup fn fields of-            Nothing          -> pure Nothing-            Just []          -> pure Nothing-            Just [x]         -> parseOne v x-            Just xs@(_:y:ys) -> do-                warnMultipleSingularFields fn xs-                NE.last <$> traverse (parseOne v) (y:|ys)--        parseOne v (MkNamelessField pos fls)-            | null fls           = pure Nothing-            | v >= CabalSpecV3_0 = pure (Just (fieldlinesToFreeText3 pos fls))-            | otherwise          = pure (Just (fieldlinesToFreeText fls))--    freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser where-        parser v fields = case Map.lookup fn fields of-            Nothing          -> pure ""-            Just []          -> pure ""-            Just [x]         -> parseOne v x-            Just xs@(_:y:ys) -> do-                warnMultipleSingularFields fn xs-                NE.last <$> traverse (parseOne v) (y:|ys)--        parseOne v (MkNamelessField pos fls)-            | null fls           = pure ""-            | v >= CabalSpecV3_0 = pure (fieldlinesToFreeText3 pos fls)-            | otherwise          = pure (fieldlinesToFreeText fls)--    -- freeTextFieldDefST = defaultFreeTextFieldDefST-    freeTextFieldDefST fn _ = ParsecFG (Set.singleton fn) Set.empty parser where-        parser v fields = case Map.lookup fn fields of-            Nothing          -> pure mempty-            Just []          -> pure mempty-            Just [x]         -> parseOne v x-            Just xs@(_:y:ys) -> do-                warnMultipleSingularFields fn xs-                NE.last <$> traverse (parseOne v) (y:|ys)--        parseOne v (MkNamelessField pos fls) = case fls of-            []                     -> pure mempty-            [FieldLine _  bs]      -> pure (ShortText.unsafeFromUTF8BS bs)-            _ | v >= CabalSpecV3_0 -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls)-              | otherwise          -> pure (ShortText.toShortText $ fieldlinesToFreeText fls)--    monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser-      where-        parser v fields = case Map.lookup fn fields of-            Nothing -> pure mempty-            Just xs -> foldMap (unpack' _pack) <$> traverse (parseOne v) xs--        parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls--    prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs))-      where-        parser :: Fields Position -> [(String, String)]-        parser values = reorder $ concatMap convert $ filter match $ Map.toList values--        match (fn, _) = fnPfx `BS.isPrefixOf` fn-        convert (fn, fields) =-            [ (pos, (fromUTF8BS fn, trim $ fromUTF8BS $ fieldlinesToBS fls))-            | MkNamelessField pos fls <- fields-            ]-        -- hack: recover the order of prefixed fields-        reorder = map snd . sortBy (comparing fst)-        trim :: String -> String-        trim = dropWhile isSpace . dropWhileEnd isSpace--    availableSince vs def (ParsecFG names prefixes parser) = ParsecFG names prefixes parser'-      where-        parser' v values-            | v >= vs = parser v values-            | otherwise = do-                let unknownFields = Map.intersection values $ Map.fromSet (const ()) names-                for_ (Map.toList unknownFields) $ \(name, fields) ->-                    for_ fields $ \(MkNamelessField pos _) ->-                        parseWarning pos PWTUnknownField $-                            "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ ". This field will be ignored."--                pure def--    availableSinceWarn vs (ParsecFG names prefixes parser) = ParsecFG names prefixes parser'-      where-        parser' v values-            | v >= vs = parser v values-            | otherwise = do-                let unknownFields = Map.intersection values $ Map.fromSet (const ()) names-                for_ (Map.toList unknownFields) $ \(name, fields) ->-                    for_ fields $ \(MkNamelessField pos _) ->-                        parseWarning pos PWTUnknownField $-                            "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ "."--                parser v values---    -- todo we know about this field-    deprecatedSince vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser'-      where-        parser' v values-            | v >= vs = do-                let deprecatedFields = Map.intersection values $ Map.fromSet (const ()) names-                for_ (Map.toList deprecatedFields) $ \(name, fields) ->-                    for_ fields $ \(MkNamelessField pos _) ->-                        parseWarning pos PWTDeprecatedField $-                            "The field " <> show name <> " is deprecated in the Cabal specification version " ++ showCabalSpecVersion vs ++ ". " ++ msg--                parser v values--            | otherwise = parser v values--    removedIn vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' where-        parser' v values-            | v >= vs = do-                let msg' = if null msg then "" else ' ' : msg-                let unknownFields = Map.intersection values $ Map.fromSet (const ()) names-                let namePos =-                      [ (name, pos)-                      | (name, fields) <- Map.toList unknownFields-                      , MkNamelessField pos _ <- fields-                      ]--                let makeMsg name = "The field " <> show name <> " is removed in the Cabal specification version " ++ showCabalSpecVersion vs ++ "." ++ msg'--                case namePos of-                    -- no fields => proceed (with empty values, to be sure)-                    [] -> parser v mempty--                    -- if there's single field: fail fatally with it-                    ((name, pos) : rest) -> do-                        for_ rest $ \(name', pos') -> parseFailure pos' $ makeMsg name'-                        parseFatalFailure pos $ makeMsg name--              | otherwise = parser v values--    knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ -> pure ())--    hiddenField = id------------------------------------------------------------------------------------ Parsec----------------------------------------------------------------------------------runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult a-runFieldParser' inputPoss p v str = case P.runParser p' [] "<field>" str of-    Right (pok, ws) -> do-        traverse_ (\(PWarning t pos w) -> parseWarning (mapPosition pos) t w) ws-        pure pok-    Left err        -> do-        let ppos = P.errorPos err-        let epos = mapPosition $ Position (P.sourceLine ppos) (P.sourceColumn ppos)--        let msg = P.showErrorMessages-                "or" "unknown parse error" "expecting" "unexpected" "end of input"-                (P.errorMessages err)-        parseFatalFailure epos $ msg ++ "\n"-  where-    p' = (,) <$ P.spaces <*> unPP p v <* P.spaces <* P.eof <*> P.getState--    -- Positions start from 1:1, not 0:0-    mapPosition (Position prow pcol) = go (prow - 1) inputPoss where-        go _ []                            = zeroPos-        go _ [Position row col]            = Position row (col + pcol - 1)-        go n (Position row col:_) | n <= 0 = Position row (col + pcol - 1)-        go n (_:ps)                        = go (n - 1) ps--runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult a-runFieldParser pp p v ls = runFieldParser' poss p v (fieldLinesToStream ls)-  where-    poss = map (\(FieldLine pos _) -> pos) ls ++ [pp] -- add "default" position--fieldlinesToBS :: [FieldLine ann] -> BS.ByteString-fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)---- Example package with dot lines--- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal-fieldlinesToFreeText :: [FieldLine ann] -> String-fieldlinesToFreeText [FieldLine _ "."] = "."-fieldlinesToFreeText fls               = intercalate "\n" (map go fls)-  where-    go (FieldLine _ bs)-        | s == "." = ""-        | otherwise = s-      where-        s = trim (fromUTF8BS bs)--        trim :: String -> String-        trim = dropWhile isSpace . dropWhileEnd isSpace--fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> String-fieldlinesToFreeText3 _   []               = ""-fieldlinesToFreeText3 _   [FieldLine _ bs] = fromUTF8BS bs-fieldlinesToFreeText3 pos (FieldLine pos1 bs1 : fls2@(FieldLine pos2 _ : _))-    -- if first line is on the same line with field name:-    -- the indentation level is either-    -- 1. the indentation of left most line in rest fields-    -- 2. the indentation of the first line-    -- whichever is leftmost-    | positionRow pos == positionRow pos1 = concat-        $ fromUTF8BS bs1-        : mealy (mk mcol1) pos1 fls2--    -- otherwise, also indent the first line-    | otherwise = concat-        $ replicate (positionCol pos1 - mcol2) ' '-        : fromUTF8BS bs1-        : mealy (mk mcol2) pos1 fls2--  where-    mcol1 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (min (positionCol pos1) (positionCol pos2)) fls2-    mcol2 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (positionCol pos1) fls2--    mk :: Int -> Position -> FieldLine Position -> (Position, String)-    mk col p (FieldLine q bs) =-        ( q-        , replicate newlines '\n'-          ++ replicate indent ' '-          ++ fromUTF8BS bs-        )-      where-        newlines = positionRow q - positionRow p-        indent   = positionCol q - col--mealy :: (s -> a -> (s, b)) -> s -> [a] -> [b]-mealy f = go where-    go _ [] = []-    go s (x : xs) = let ~(s', y) = f s x in y : go s' xs--fieldLinesToStream :: [FieldLine ann] -> FieldLineStream-fieldLinesToStream []                    = fieldLineStreamEnd-fieldLinesToStream [FieldLine _ bs]      = FLSLast bs-fieldLinesToStream (FieldLine _ bs : fs) = FLSCons bs (fieldLinesToStream fs)
− src/Distribution/FieldGrammar/Pretty.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE DeriveFunctor         #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Distribution.FieldGrammar.Pretty (-    PrettyFieldGrammar,-    prettyFieldGrammar,-    ) where--import           Distribution.CabalSpecVersion-import           Distribution.Compat.Lens-import           Distribution.Compat.Newtype-import           Distribution.Compat.Prelude-import           Distribution.Fields.Field     (FieldName)-import           Distribution.Fields.Pretty    (PrettyField (..))-import           Distribution.Pretty           (Pretty (..), showFreeText, showFreeTextV3)-import           Distribution.Simple.Utils     (toUTF8BS)-import           Prelude ()-import           Text.PrettyPrint              (Doc)-import qualified Text.PrettyPrint              as PP--import Distribution.FieldGrammar.Class--newtype PrettyFieldGrammar s a = PrettyFG-    { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField ()]-    }-  deriving (Functor)--instance Applicative (PrettyFieldGrammar s) where-    pure _ = PrettyFG (\_ _ -> mempty)-    PrettyFG f <*> PrettyFG x = PrettyFG (\v s -> f v s <> x v s)---- | We can use 'PrettyFieldGrammar' to pp print the @s@.------ /Note:/ there is not trailing @($+$ text "")@.-prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()]-prettyFieldGrammar = flip fieldGrammarPretty--instance FieldGrammar Pretty PrettyFieldGrammar where-    blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f)--    uniqueFieldAla fn _pack l = PrettyFG $ \_v s ->-        ppField fn (pretty (pack' _pack (aview l s)))--    booleanFieldDef fn l def = PrettyFG pp-      where-        pp _v s-            | b == def  = mempty-            | otherwise = ppField fn (PP.text (show b))-          where-            b = aview l s--    optionalFieldAla fn _pack l = PrettyFG pp-      where-        pp v s = case aview l s of-            Nothing -> mempty-            Just a  -> ppField fn (prettyVersioned v (pack' _pack a))--    optionalFieldDefAla fn _pack l def = PrettyFG pp-      where-        pp v s-            | x == def  = mempty-            | otherwise = ppField fn (prettyVersioned v (pack' _pack x))-          where-            x = aview l s--    freeTextField fn l = PrettyFG pp where-        pp v s = maybe mempty (ppField fn . showFT) (aview l s) where-            showFT | v >= CabalSpecV3_0 = showFreeTextV3-                   | otherwise          = showFreeText--    -- it's ok to just show, as showFreeText of empty string is empty.-    freeTextFieldDef fn l = PrettyFG pp where-        pp v s = ppField fn (showFT (aview l s)) where-            showFT | v >= CabalSpecV3_0 = showFreeTextV3-                   | otherwise          = showFreeText--    freeTextFieldDefST = defaultFreeTextFieldDefST--    monoidalFieldAla fn _pack l = PrettyFG pp-      where-        pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s)))--    prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l)-      where-        pp xs =-            -- always print the field, even its Doc is empty.-            -- i.e. don't use ppField-            [ PrettyField () (toUTF8BS n) $ PP.vcat $ map PP.text $ lines s-            | (n, s) <- xs-            -- fnPfx `isPrefixOf` n-            ]--    knownField _           = pure ()-    deprecatedSince _ _ x  = x-    -- TODO: as PrettyFieldGrammar isn't aware of cabal-version: we output the field-    -- this doesn't affect roundtrip as `removedIn` fields cannot be parsed-    -- so invalid documents can be only manually constructed.-    removedIn _ _ x        = x-    availableSince _ _     = id-    hiddenField _          = PrettyFG (\_ -> mempty)--ppField :: FieldName -> Doc -> [PrettyField ()]-ppField name fielddoc-    | PP.isEmpty fielddoc = []-    | otherwise        = [ PrettyField () name fielddoc ]
− src/Distribution/Fields.hs 
@@ -1,42 +0,0 @@--- | Utilitiies to work with @.cabal@ like file structure.-module Distribution.Fields (-    -- * Types-    Field(..),-    Name(..),-    FieldLine(..),-    SectionArg(..),-    FieldName,-    -- * Grammar and parsing-    ---    -- See "Distribution.Fields.Parser" for grammar.-    readFields,-    readFields',-    -- ** ParseResult-    ParseResult,-    runParseResult,-    parseString,-    parseWarning,-    parseWarnings,-    parseFailure,-    parseFatalFailure,-    -- ** Warnings-    PWarnType (..),-    PWarning (..),-    showPWarning,-    -- ** Errors-    PError (..),-    showPError,-    -- * Pretty printing-    PrettyField (..),-    showFields,-    -- ** Transformation from Field-    genericFromParsecFields,-    fromParsecFields,-    ) where--import Distribution.Fields.Field-import Distribution.Fields.Parser-import Distribution.Fields.ParseResult-import Distribution.Fields.Pretty-import Distribution.Parsec.Error-import Distribution.Parsec.Warning
− src/Distribution/Fields/ConfVar.hs 
@@ -1,126 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Distribution.Fields.ConfVar (parseConditionConfVar) where--import Distribution.Compat.CharParsing     (char, integral)-import Distribution.Compat.Prelude-import Distribution.Fields.Field           (SectionArg (..))-import Distribution.Fields.ParseResult-import Distribution.Parsec                 (Parsec (..), Position (..), runParsecParser)-import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)-import Distribution.Types.Condition-import Distribution.Types.ConfVar          (ConfVar (..))-import Distribution.Version-       (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, majorBoundVersion,-       mkVersion, noVersion, orEarlierVersion, orLaterVersion, thisVersion, unionVersionRanges,-       withinVersion)-import Prelude ()--import qualified Text.Parsec       as P-import qualified Text.Parsec.Error as P---- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec--- based outline parser.-parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar)-parseConditionConfVar args =-    -- The name of the input file is irrelevant, as we reformat the error message.-    case P.runParser (parser <* P.eof) () "<condition>" args of-        Right x  -> pure x-        Left err -> do-            -- Mangle the position to the actual one-            let ppos = P.errorPos err-            let epos = Position (P.sourceLine ppos) (P.sourceColumn ppos)-            let msg = P.showErrorMessages-                    "or" "unknown parse error" "expecting" "unexpected" "end of input"-                    (P.errorMessages err)-            parseFailure epos msg-            pure $ Lit True--type Parser = P.Parsec [SectionArg Position] ()--sepByNonEmpty :: Parser a -> Parser sep -> Parser (NonEmpty a)-sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p)--parser :: Parser (Condition ConfVar)-parser = condOr-  where-    condOr       = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr-    condAnd      = sepByNonEmpty cond    (oper "&&") >>= return . foldl1 CAnd-    cond         = P.choice-         [ boolLiteral, parens condOr,  notCond, osCond, archCond, flagCond, implCond ]--    notCond      = CNot <$ oper "!" <*> cond--    boolLiteral  = Lit <$> boolLiteral'-    osCond       = Var . OS   <$ string "os"   <*> parens fromParsec-    flagCond     = Var . PackageFlag <$ string "flag" <*> parens fromParsec-    archCond     = Var . Arch <$ string "arch" <*> parens fromParsec-    implCond     = Var        <$ string "impl" <*> parens implCond'--    implCond'    = Impl-        <$> fromParsec-        <*> P.option anyVersion versionRange--    version = fromParsec-    versionStar  = mkVersion <$> fromParsec' versionStar' <* oper "*"-    versionStar' = some (integral <* char '.')--    versionRange = expr-      where-        expr = foldl1 unionVersionRanges     <$> sepByNonEmpty term   (oper "||")-        term = foldl1 intersectVersionRanges <$> sepByNonEmpty factor (oper "&&")--        factor = P.choice-            $ parens expr-            : parseAnyVersion-            : parseNoVersion-            : parseWildcardRange-            : map parseRangeOp rangeOps--        parseAnyVersion    = anyVersion <$ string "-any"-        parseNoVersion     = noVersion  <$ string "-none"--        parseWildcardRange = P.try $ withinVersion <$ oper "==" <*> versionStar--        parseRangeOp (s,f) = P.try (f <$ oper s <*> version)-        rangeOps = [ ("<",  earlierVersion),-                     ("<=", orEarlierVersion),-                     (">",  laterVersion),-                     (">=", orLaterVersion),-                     ("^>=", majorBoundVersion),-                     ("==", thisVersion) ]--    -- Number token can have many dots in it: SecArgNum (Position 65 15) "7.6.1"-    identBS = tokenPrim $ \t -> case t of-        SecArgName _ s -> Just s-        _              -> Nothing--    boolLiteral' = tokenPrim $ \t -> case t of-        SecArgName _ s-            | s == "True"  -> Just True-            | s == "true"  -> Just True-            | s == "False" -> Just False-            | s == "false" -> Just False-        _                  -> Nothing--    string s = tokenPrim $ \t -> case t of-        SecArgName _ s' | s == s' -> Just ()-        _                         -> Nothing--    oper o = tokenPrim $ \t -> case t of-        SecArgOther _ o' | o == o' -> Just ()-        _                          -> Nothing--    parens = P.between (oper "(") (oper ")")--    tokenPrim = P.tokenPrim prettySectionArg updatePosition-    -- TODO: check where the errors are reported-    updatePosition x _ _ = x-    prettySectionArg = show--    fromParsec :: Parsec a => Parser a-    fromParsec = fromParsec' parsec--    fromParsec' p = do-        bs <- identBS-        let fls = fieldLineStreamFromBS bs-        either (fail . show) pure (runParsecParser p "<fromParsec'>" fls)
− src/Distribution/Fields/Field.hs 
@@ -1,141 +0,0 @@-{-# LANGUAGE DeriveFoldable    #-}-{-# LANGUAGE DeriveFunctor     #-}-{-# LANGUAGE DeriveTraversable #-}--- | Cabal-like file AST types: 'Field', 'Section' etc------ These types are parametrized by an annotation.-module Distribution.Fields.Field (-    -- * Cabal file-    Field (..),-    fieldName,-    fieldAnn,-    fieldUniverse,-    FieldLine (..),-    fieldLineAnn,-    fieldLineBS,-    SectionArg (..),-    sectionArgAnn,-    -- * Name-    FieldName,-    Name (..),-    mkName,-    getName,-    nameAnn,-    -- * Conversions to String-    sectionArgsToString,-    fieldLinesToString,-    ) where--import           Data.ByteString             (ByteString)-import qualified Data.ByteString.Char8       as B-import qualified Data.Char                   as Char-import           Distribution.Compat.Prelude-import           Distribution.Pretty         (showTokenStr)-import           Distribution.Simple.Utils   (fromUTF8BS)-import           Prelude ()------------------------------------------------------------------------------------- Cabal file------------------------------------------------------------------------------------ | A Cabal-like file consists of a series of fields (@foo: bar@) and sections (@library ...@).-data Field ann-    = Field   !(Name ann) [FieldLine ann]-    | Section !(Name ann) [SectionArg ann] [Field ann]-  deriving (Eq, Show, Functor, Foldable, Traversable)---- | Section of field name-fieldName :: Field ann -> Name ann-fieldName (Field n _ )    = n-fieldName (Section n _ _) = n--fieldAnn :: Field ann -> ann-fieldAnn = nameAnn . fieldName---- | All transitive descendants of 'Field', including itself.------ /Note:/ the resulting list is never empty.----fieldUniverse :: Field ann -> [Field ann]-fieldUniverse f@(Section _ _ fs) = f : concatMap fieldUniverse fs-fieldUniverse f@(Field _ _)      = [f]---- | A line of text representing the value of a field from a Cabal file.--- A field may contain multiple lines.------ /Invariant:/ 'ByteString' has no newlines.-data FieldLine ann  = FieldLine  !ann !ByteString-  deriving (Eq, Show, Functor, Foldable, Traversable)---- | @since 3.0.0.0-fieldLineAnn :: FieldLine ann -> ann-fieldLineAnn (FieldLine ann _) = ann---- | @since 3.0.0.0-fieldLineBS :: FieldLine ann -> ByteString-fieldLineBS (FieldLine _ bs) = bs---- | Section arguments, e.g. name of the library-data SectionArg ann-    = SecArgName  !ann !ByteString-      -- ^ identifier, or something which looks like number. Also many dot numbers, i.e. "7.6.3"-    | SecArgStr   !ann !ByteString-      -- ^ quoted string-    | SecArgOther !ann !ByteString-      -- ^ everything else, mm. operators (e.g. in if-section conditionals)-  deriving (Eq, Show, Functor, Foldable, Traversable)---- | Extract annotation from 'SectionArg'.-sectionArgAnn :: SectionArg ann -> ann-sectionArgAnn (SecArgName ann _)  = ann-sectionArgAnn (SecArgStr ann _)   = ann-sectionArgAnn (SecArgOther ann _) = ann------------------------------------------------------------------------------------ Name----------------------------------------------------------------------------------type FieldName = ByteString---- | A field name.------ /Invariant/: 'ByteString' is lower-case ASCII.-data Name ann  = Name       !ann !FieldName-  deriving (Eq, Show, Functor, Foldable, Traversable)--mkName :: ann -> FieldName -> Name ann-mkName ann bs = Name ann (B.map Char.toLower bs)--getName :: Name ann -> FieldName-getName (Name _ bs) = bs--nameAnn :: Name ann -> ann-nameAnn (Name ann _) = ann------------------------------------------------------------------------------------ To Strings------------------------------------------------------------------------------------ |------ @since 3.6.0.0-sectionArgsToString :: [SectionArg ann] -> String-sectionArgsToString = unwords . map toStr where-    toStr :: SectionArg ann -> String-    toStr (SecArgName _ bs)  = showTokenStr (fromUTF8BS bs)-    toStr (SecArgStr _ bs)   = showTokenStr (fromUTF8BS bs)-    toStr (SecArgOther _ bs) = fromUTF8BS bs---- | Convert @['FieldLine']@ into String.------ /Note:/ this doesn't preserve indentation or empty lines,--- as the annotations (e.g. positions) are ignored.------ @since 3.6.0.0-fieldLinesToString :: [FieldLine ann] -> String-fieldLinesToString =-    -- intercalate to avoid trailing newline.-    intercalate "\n" . map toStr-  where-    toStr (FieldLine _ bs) = fromUTF8BS bs
− src/Distribution/Fields/Lexer.hs 
@@ -1,496 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-}-{-# LANGUAGE CPP,MagicHash #-}-{-# LINE 1 "templates/Lexer.x" #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Fields.Lexer--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Lexer for the cabal files.-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#ifdef CABAL_PARSEC_DEBUG-{-# LANGUAGE PatternGuards #-}-#endif-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-module Distribution.Fields.Lexer-  (ltest, lexToken, Token(..), LToken(..)-  ,bol_section, in_section, in_field_layout, in_field_braces-  ,mkLexState) where---- [Note: boostrapping parsec parser]------ We manually produce the `Lexer.hs` file from `boot/Lexer.x` (make lexer)--- because boostrapping cabal-install would be otherwise tricky.--- Alex is (atm) tricky package to build, cabal-install has some magic--- to move bundled generated files in place, so rather we don't depend--- on it before we can build it ourselves.--- Therefore there is one thing less to worry in bootstrap.sh, which is a win.------ See also https://github.com/haskell/cabal/issues/4633-----import Prelude ()-import qualified Prelude as Prelude-import Distribution.Compat.Prelude--import Distribution.Fields.LexerMonad-import Distribution.Parsec.Position (Position (..), incPos, retPos)-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B.Char8-import qualified Data.Word as Word--#ifdef CABAL_PARSEC_DEBUG-import Debug.Trace-import qualified Data.Vector as V-import qualified Data.Text   as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Encoding.Error as T-#endif--#if __GLASGOW_HASKELL__ >= 603-#include "ghcconfig.h"-#elif defined(__GLASGOW_HASKELL__)-#include "config.h"-#endif-#if __GLASGOW_HASKELL__ >= 503-import Data.Array-#else-import Array-#endif-#if __GLASGOW_HASKELL__ >= 503-import Data.Array.Base (unsafeAt)-import GHC.Exts-#else-import GlaExts-#endif-alex_tab_size :: Int-alex_tab_size = 8-alex_base :: AlexAddr-alex_base = AlexA#-  "\x12\xff\xff\xff\xf9\xff\xff\xff\xfb\xff\xff\xff\x01\x00\x00\x00\x2f\x00\x00\x00\x50\x00\x00\x00\xd0\x00\x00\x00\x48\xff\xff\xff\xdc\xff\xff\xff\x51\xff\xff\xff\x6d\xff\xff\xff\x6f\xff\xff\xff\x50\x01\x00\x00\x74\x01\x00\x00\x70\xff\xff\xff\x68\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\xa3\x01\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\xd1\x01\x00\x00\xfb\x01\x00\x00\x7b\x02\x00\x00\xfb\x02\x00\x00\x00\x00\x00\x00\x7b\x03\x00\x00\x7d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x6d\x00\x00\x00\x6b\x00\x00\x00\xfc\x03\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x6f\x00\x00\x00\x1c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00"#--alex_table :: AlexAddr-alex_table = AlexA#-  "\x00\x00\x09\x00\x0f\x00\x11\x00\x02\x00\x11\x00\x12\x00\x00\x00\x12\x00\x13\x00\x03\x00\x11\x00\x07\x00\x10\x00\x12\x00\x25\x00\x14\x00\x11\x00\x10\x00\x11\x00\x14\x00\x11\x00\x12\x00\x23\x00\x12\x00\x0f\x00\x28\x00\x02\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x08\x00\x10\x00\x00\x00\x14\x00\x00\x00\x00\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x2e\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x0f\x00\x11\x00\x17\x00\x26\x00\x12\x00\x25\x00\x11\x00\x2a\x00\x00\x00\x12\x00\x00\x00\x15\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x17\x00\x26\x00\x00\x00\x25\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0e\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\x23\x00\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\x1e\x00\x0d\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x1f\x00\x1f\x00\x1e\x00\x1e\x00\x1e\x00\x19\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x1f\x00\x1e\x00\x1f\x00\x1e\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x1e\x00\x22\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1d\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1e\x00\xff\xff\xff\xff\xff\xff\x1e\x00\x1e\x00\x1e\x00\x18\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\xff\xff\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1a\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1c\x00\x1e\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x1e\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--alex_check :: AlexAddr-alex_check = AlexA#-  "\xff\xff\xef\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\x0d\x00\xbf\x00\x0d\x00\x2d\x00\x09\x00\x0a\x00\xbb\x00\xa0\x00\x0d\x00\xa0\x00\xa0\x00\x0a\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\x0d\x00\x0a\x00\x0d\x00\x20\x00\x0a\x00\x20\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\x2d\x00\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\x2d\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x09\x00\x0a\x00\x09\x00\x09\x00\x0d\x00\x09\x00\x0a\x00\x09\x00\xff\xff\x0d\x00\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x20\x00\x20\x00\xff\xff\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xc2\x00\xff\xff\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x5c\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\x5c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x7f\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7f\x00\x7e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--alex_deflt :: AlexAddr-alex_deflt = AlexA#-  "\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x27\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xff\xff\x18\x00\x1b\x00\x1b\x00\x1b\x00\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\xff\xff\xff\xff\xff\xff"#--alex_accept = listArray (0 :: Int, 47)-  [ AlexAcc 29-  , AlexAcc 28-  , AlexAcc 27-  , AlexAcc 26-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAcc 25-  , AlexAcc 24-  , AlexAccSkip-  , AlexAcc 23-  , AlexAcc 22-  , AlexAcc 21-  , AlexAccSkip-  , AlexAccSkip-  , AlexAcc 20-  , AlexAcc 19-  , AlexAcc 18-  , AlexAcc 17-  , AlexAcc 16-  , AlexAcc 15-  , AlexAcc 14-  , AlexAcc 13-  , AlexAcc 12-  , AlexAcc 11-  , AlexAcc 10-  , AlexAcc 9-  , AlexAcc 8-  , AlexAccSkip-  , AlexAcc 7-  , AlexAcc 6-  , AlexAcc 5-  , AlexAccSkip-  , AlexAcc 4-  , AlexAcc 3-  , AlexAcc 2-  , AlexAcc 1-  , AlexAcc 0-  ]--alex_actions = array (0 :: Int, 30)-  [ (29,alex_action_0)-  , (28,alex_action_20)-  , (27,alex_action_16)-  , (26,alex_action_3)-  , (25,alex_action_1)-  , (24,alex_action_1)-  , (23,alex_action_3)-  , (22,alex_action_4)-  , (21,alex_action_5)-  , (20,alex_action_8)-  , (19,alex_action_8)-  , (18,alex_action_8)-  , (17,alex_action_9)-  , (16,alex_action_9)-  , (15,alex_action_10)-  , (14,alex_action_11)-  , (13,alex_action_12)-  , (12,alex_action_13)-  , (11,alex_action_14)-  , (10,alex_action_15)-  , (9,alex_action_15)-  , (8,alex_action_16)-  , (7,alex_action_18)-  , (6,alex_action_19)-  , (5,alex_action_19)-  , (4,alex_action_22)-  , (3,alex_action_23)-  , (2,alex_action_24)-  , (1,alex_action_25)-  , (0,alex_action_25)-  ]--{-# LINE 151 "templates/Lexer.x" #-}---- | Tokens of outer cabal file structure. Field values are treated opaquely.-data Token = TokSym   !ByteString       -- ^ Haskell-like identifier, number or operator-           | TokStr   !ByteString       -- ^ String in quotes-           | TokOther !ByteString       -- ^ Operators and parens-           | Indent   !Int              -- ^ Indentation token-           | TokFieldLine !ByteString   -- ^ Lines after @:@-           | Colon-           | OpenBrace-           | CloseBrace-           | EOF-           | LexicalError InputStream --TODO: add separate string lexical error-  deriving Show--data LToken = L !Position !Token-  deriving Show--toki :: (ByteString -> Token) -> Position -> Int -> ByteString -> Lex LToken-toki t pos  len  input = return $! L pos (t (B.take len input))--tok :: Token -> Position -> Int -> ByteString -> Lex LToken-tok  t pos _len _input = return $! L pos t--checkLeadingWhitespace :: Int -> ByteString -> Lex Int-checkLeadingWhitespace len bs-    | B.any (== 9) (B.take len bs) = do-        addWarning LexWarningTab-        checkWhitespace len bs-    | otherwise = checkWhitespace len bs--checkWhitespace :: Int -> ByteString -> Lex Int-checkWhitespace len bs-    | B.any (== 194) (B.take len bs) = do-        addWarning LexWarningNBSP-        return $ len - B.count 194 (B.take len bs)-    | otherwise = return len---- -------------------------------------------------------------------------------- The input type--type AlexInput = InputStream--alexInputPrevChar :: AlexInput -> Char-alexInputPrevChar _ = error "alexInputPrevChar not used"--alexGetByte :: AlexInput -> Maybe (Word.Word8,AlexInput)-alexGetByte = B.uncons--lexicalError :: Position -> InputStream -> Lex LToken-lexicalError pos inp = do-  setInput B.empty-  return $! L pos (LexicalError inp)--lexToken :: Lex LToken-lexToken = do-  pos <- getPos-  inp <- getInput-  st  <- getStartCode-  case alexScan inp st of-    AlexEOF -> return (L pos EOF)-    AlexError inp' ->-        let !len_bytes = B.length inp - B.length inp' in-            --FIXME: we want len_chars here really-            -- need to decode utf8 up to this point-        lexicalError (incPos len_bytes pos) inp'-    AlexSkip  inp' len_chars -> do-        checkPosition pos inp inp' len_chars-        adjustPos (incPos len_chars)-        setInput inp'-        lexToken-    AlexToken inp' len_chars action -> do-        checkPosition pos inp inp' len_chars-        adjustPos (incPos len_chars)-        setInput inp'-        let !len_bytes = B.length inp - B.length inp'-        t <- action pos len_bytes inp-        --traceShow t $ return tok-        return t--checkPosition :: Position -> ByteString -> ByteString -> Int -> Lex ()-#ifdef CABAL_PARSEC_DEBUG-checkPosition pos@(Position lineno colno) inp inp' len_chars = do-    text_lines <- getDbgText-    let len_bytes = B.length inp - B.length inp'-        pos_txt   | lineno-1 < V.length text_lines = T.take len_chars (T.drop (colno-1) (text_lines V.! (lineno-1)))-                  | otherwise = T.empty-        real_txt  = B.take len_bytes inp-    when (pos_txt /= T.decodeUtf8 real_txt) $-      traceShow (pos, pos_txt, T.decodeUtf8 real_txt) $-      traceShow (take 3 (V.toList text_lines)) $ return ()-  where-    getDbgText = Lex $ \s@LexState{ dbgText = txt } -> LexResult s txt-#else-checkPosition _ _ _ _ = return ()-#endif--lexAll :: Lex [LToken]-lexAll = do-  t <- lexToken-  case t of-    L _ EOF -> return [t]-    _       -> do ts <- lexAll-                  return (t : ts)--ltest :: Int -> String -> Prelude.IO ()-ltest code s =-  let (ws, xs) = execLexer (setStartCode code >> lexAll) (B.Char8.pack s)-   in traverse_ print ws >> traverse_ print xs--mkLexState :: ByteString -> LexState-mkLexState input = LexState-  { curPos   = Position 1 1-  , curInput = input-  , curCode  = 0-  , warnings = []-#ifdef CABAL_PARSEC_DEBUG-  , dbgText  = V.fromList . lines' . T.decodeUtf8With T.lenientDecode $ input-#endif-  }--#ifdef CABAL_PARSEC_DEBUG-lines' :: T.Text -> [T.Text]-lines' s1-  | T.null s1 = []-  | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of-                  (l, s2) | Just (c,s3) <- T.uncons s2-                         -> case T.uncons s3 of-                              Just ('\n', s4) | c == '\r' -> l `T.snoc` '\r' `T.snoc` '\n' : lines' s4-                              _                           -> l `T.snoc` c : lines' s3--                          | otherwise-                         -> [l]-#endif--bol_field_braces,bol_field_layout,bol_section,in_field_braces,in_field_layout,in_section :: Int-bol_field_braces = 1-bol_field_layout = 2-bol_section = 3-in_field_braces = 4-in_field_layout = 5-in_section = 6-alex_action_0 =  \_ len _ -> do-              when (len /= 0) $ addWarning LexWarningBOM-              setStartCode bol_section-              lexToken-         -alex_action_1 =  \_pos len inp -> checkWhitespace len inp >> adjustPos retPos >> lexToken -alex_action_3 =  \pos len inp -> checkLeadingWhitespace len inp >>-                                     if B.length inp == len-                                       then return (L pos EOF)-                                       else setStartCode in_section-                                         >> return (L pos (Indent len)) -alex_action_4 =  tok  OpenBrace -alex_action_5 =  tok  CloseBrace -alex_action_8 =  toki TokSym -alex_action_9 =  \pos len inp -> return $! L pos (TokStr (B.take (len - 2) (B.tail inp))) -alex_action_10 =  toki TokOther -alex_action_11 =  toki TokOther -alex_action_12 =  tok  Colon -alex_action_13 =  tok  OpenBrace -alex_action_14 =  tok  CloseBrace -alex_action_15 =  \_ _ _ -> adjustPos retPos >> setStartCode bol_section >> lexToken -alex_action_16 =  \pos len inp -> checkLeadingWhitespace len inp >>= \len' ->-                                  if B.length inp == len-                                    then return (L pos EOF)-                                    else setStartCode in_field_layout-                                      >> return (L pos (Indent len')) -alex_action_18 =  toki TokFieldLine -alex_action_19 =  \_ _ _ -> adjustPos retPos >> setStartCode bol_field_layout >> lexToken -alex_action_20 =  \_ _ _ -> setStartCode in_field_braces >> lexToken -alex_action_22 =  toki TokFieldLine -alex_action_23 =  tok  OpenBrace  -alex_action_24 =  tok  CloseBrace -alex_action_25 =  \_ _ _ -> adjustPos retPos >> setStartCode bol_field_braces >> lexToken -{-# LINE 1 "templates/GenericTemplate.hs" #-}--- -------------------------------------------------------------------------------- ALEX TEMPLATE------ This code is in the PUBLIC DOMAIN; you may copy it freely and use--- it for any purpose whatsoever.---- -------------------------------------------------------------------------------- INTERNALS and main scanner engine---- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.-#if __GLASGOW_HASKELL__ > 706-#define GTE(n,m) (tagToEnum# (n >=# m))-#define EQ(n,m) (tagToEnum# (n ==# m))-#else-#define GTE(n,m) (n >=# m)-#define EQ(n,m) (n ==# m)-#endif--data AlexAddr = AlexA# Addr#--- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.-#if __GLASGOW_HASKELL__ < 503-uncheckedShiftL# = shiftL#-#endif--{-# INLINE alexIndexInt16OffAddr #-}-alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int#-alexIndexInt16OffAddr (AlexA# arr) off =-#ifdef WORDS_BIGENDIAN-  narrow16Int# i-  where-        i    = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)-        high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))-        low  = int2Word# (ord# (indexCharOffAddr# arr off'))-        off' = off *# 2#-#else-#if __GLASGOW_HASKELL__ >= 901-  int16ToInt#-#endif-    (indexInt16OffAddr# arr off)-#endif--{-# INLINE alexIndexInt32OffAddr #-}-alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int#-alexIndexInt32OffAddr (AlexA# arr) off =-#ifdef WORDS_BIGENDIAN-  narrow32Int# i-  where-   i    = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`-                     (b2 `uncheckedShiftL#` 16#) `or#`-                     (b1 `uncheckedShiftL#` 8#) `or#` b0)-   b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))-   b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))-   b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))-   b0   = int2Word# (ord# (indexCharOffAddr# arr off'))-   off' = off *# 4#-#else-#if __GLASGOW_HASKELL__ >= 901-  int32ToInt#-#endif-    (indexInt32OffAddr# arr off)-#endif--#if __GLASGOW_HASKELL__ < 503-quickIndex arr i = arr ! i-#else--- GHC >= 503, unsafeAt is available from Data.Array.Base.-quickIndex = unsafeAt-#endif---- -------------------------------------------------------------------------------- Main lexing routines--data AlexReturn a-  = AlexEOF-  | AlexError  !AlexInput-  | AlexSkip   !AlexInput !Int-  | AlexToken  !AlexInput !Int a---- alexScan :: AlexInput -> StartCode -> AlexReturn a-alexScan input__ (I# (sc))-  = alexScanUser undefined input__ (I# (sc))--alexScanUser user__ input__ (I# (sc))-  = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of-  (AlexNone, input__') ->-    case alexGetByte input__ of-      Nothing ->--                                   AlexEOF-      Just _ ->--                                   AlexError input__'--  (AlexLastSkip input__'' len, _) ->--    AlexSkip input__'' len--  (AlexLastAcc k input__''' len, _) ->--    AlexToken input__''' len (alex_actions ! k)---- Push the input through the DFA, remembering the most recent accepting--- state it encountered.--alex_scan_tkn user__ orig_input len input__ s last_acc =-  input__ `seq` -- strict in the input-  let-  new_acc = (check_accs (alex_accept `quickIndex` (I# (s))))-  in-  new_acc `seq`-  case alexGetByte input__ of-     Nothing -> (new_acc, input__)-     Just (c, new_input) ->--      case fromIntegral c of { (I# (ord_c)) ->-        let-                base   = alexIndexInt32OffAddr alex_base s-                offset = (base +# ord_c)-                check  = alexIndexInt16OffAddr alex_check offset--                new_s = if GTE(offset,0#) && EQ(check,ord_c)-                          then alexIndexInt16OffAddr alex_table offset-                          else alexIndexInt16OffAddr alex_deflt s-        in-        case new_s of-            -1# -> (new_acc, input__)-                -- on an error, we want to keep the input *before* the-                -- character that failed, not after.-            _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len)-                                                -- note that the length is increased ONLY if this is the 1st byte in a char encoding)-                        new_input new_s new_acc-      }-  where-        check_accs (AlexAccNone) = last_acc-        check_accs (AlexAcc a  ) = AlexLastAcc a input__ (I# (len))-        check_accs (AlexAccSkip) = AlexLastSkip  input__ (I# (len))--data AlexLastAcc-  = AlexNone-  | AlexLastAcc !Int !AlexInput !Int-  | AlexLastSkip     !AlexInput !Int--data AlexAcc user-  = AlexAccNone-  | AlexAcc Int-  | AlexAccSkip-
− src/Distribution/Fields/LexerMonad.hs 
@@ -1,155 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Fields.LexerMonad--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable-module Distribution.Fields.LexerMonad (-    InputStream,-    LexState(..),-    LexResult(..),--    Lex(..),-    execLexer,--    getPos,-    setPos,-    adjustPos,--    getInput,-    setInput,--    getStartCode,-    setStartCode,--    LexWarning(..),-    LexWarningType(..),-    addWarning,-    toPWarnings,--  ) where--import qualified Data.ByteString              as B-import qualified Data.List.NonEmpty           as NE-import           Distribution.Compat.Prelude-import           Distribution.Parsec.Position (Position (..), showPos)-import           Distribution.Parsec.Warning  (PWarnType (..), PWarning (..))-import           Prelude ()--import qualified Data.Map.Strict as Map--#ifdef CABAL_PARSEC_DEBUG--- testing only:-import qualified Data.Text          as T-import qualified Data.Text.Encoding as T-import qualified Data.Vector        as V-#endif---- simple state monad-newtype Lex a = Lex { unLex :: LexState -> LexResult a }--instance Functor Lex where-  fmap = liftM--instance Applicative Lex where-  pure = returnLex-  (<*>) = ap--instance Monad Lex where-  return = pure-  (>>=)  = thenLex--data LexResult a = LexResult {-# UNPACK #-} !LexState a--data LexWarningType-    = LexWarningNBSP  -- ^ Encountered non breaking space-    | LexWarningBOM   -- ^ BOM at the start of the cabal file-    | LexWarningTab   -- ^ Leading tags-  deriving (Eq, Ord, Show)--data LexWarning = LexWarning                !LexWarningType-                             {-# UNPACK #-} !Position-  deriving (Show)--toPWarnings :: [LexWarning] -> [PWarning]-toPWarnings-    = map (uncurry toWarning)-    . Map.toList-    . Map.fromListWith (<>)-    . map (\(LexWarning t p) -> (t, pure p))-  where-    toWarning LexWarningBOM poss =-        PWarning PWTLexBOM (NE.head poss) "Byte-order mark found at the beginning of the file"-    toWarning LexWarningNBSP poss =-        PWarning PWTLexNBSP (NE.head poss) $ "Non breaking spaces at " ++ intercalate ", " (NE.toList $ fmap showPos poss)-    toWarning LexWarningTab poss =-        PWarning PWTLexTab (NE.head poss) $ "Tabs used as indentation at " ++ intercalate ", " (NE.toList $ fmap showPos poss)--data LexState = LexState {-        curPos   :: {-# UNPACK #-} !Position,        -- ^ position at current input location-        curInput :: {-# UNPACK #-} !InputStream,     -- ^ the current input-        curCode  :: {-# UNPACK #-} !StartCode,       -- ^ lexer code-        warnings :: [LexWarning]-#ifdef CABAL_PARSEC_DEBUG-        , dbgText  :: V.Vector T.Text                -- ^ input lines, to print pretty debug info-#endif-     } --TODO: check if we should cache the first token-       -- since it looks like parsec's uncons can be called many times on the same input--type StartCode   = Int    -- ^ An @alex@ lexer start code-type InputStream = B.ByteString------ | Execute the given lexer on the supplied input stream.-execLexer :: Lex a -> InputStream -> ([LexWarning], a)-execLexer (Lex lexer) input =-    case lexer initialState of-      LexResult LexState{ warnings = ws } result -> (ws, result)-  where-    initialState = LexState-      -- TODO: add 'startPosition'-      { curPos   = Position 1 1-      , curInput = input-      , curCode  = 0-      , warnings = []-#ifdef CABAL_PARSEC_DEBUG-      , dbgText  = V.fromList . T.lines . T.decodeUtf8 $ input-#endif-      }--{-# INLINE returnLex #-}-returnLex :: a -> Lex a-returnLex a = Lex $ \s -> LexResult s a--{-# INLINE thenLex #-}-thenLex :: Lex a -> (a -> Lex b) -> Lex b-(Lex m) `thenLex` k = Lex $ \s -> case m s of LexResult s' a -> (unLex (k a)) s'--setPos :: Position -> Lex ()-setPos pos = Lex $ \s -> LexResult s{ curPos = pos } ()--getPos :: Lex Position-getPos = Lex $ \s@LexState{ curPos = pos } -> LexResult s pos--adjustPos :: (Position -> Position) -> Lex ()-adjustPos f = Lex $ \s@LexState{ curPos = pos } -> LexResult s{ curPos = f pos } ()--getInput :: Lex InputStream-getInput = Lex $ \s@LexState{ curInput = i } -> LexResult s i--setInput :: InputStream -> Lex ()-setInput i = Lex $ \s -> LexResult s{ curInput = i } ()--getStartCode :: Lex Int-getStartCode = Lex $ \s@LexState{ curCode = c } -> LexResult s c--setStartCode :: Int -> Lex ()-setStartCode c = Lex $ \s -> LexResult s{ curCode = c } ()---- | Add warning at the current position-addWarning :: LexWarningType -> Lex ()-addWarning wt = Lex $ \s@LexState{ curPos = pos, warnings = ws  } ->-    LexResult s{ warnings = LexWarning wt pos : ws } ()
− src/Distribution/Fields/ParseResult.hs 
@@ -1,196 +0,0 @@-{-# LANGUAGE BangPatterns     #-}-{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes       #-}--- | A parse result type for parsers from AST to Haskell types.-module Distribution.Fields.ParseResult (-    ParseResult,-    runParseResult,-    recoverWith,-    parseWarning,-    parseWarnings,-    parseFailure,-    parseFatalFailure,-    parseFatalFailure',-    getCabalSpecVersion,-    setCabalSpecVersion,-    readAndParseFile,-    parseString,-    withoutWarnings,-    ) where--import qualified Data.ByteString.Char8        as BS-import           Distribution.Compat.Prelude-import           Distribution.Parsec.Error    (PError (..), showPError)-import           Distribution.Parsec.Position (Position (..), zeroPos)-import           Distribution.Parsec.Warning  (PWarnType (..), PWarning (..), showPWarning)-import           Distribution.Simple.Utils    (die', warn)-import           Distribution.Verbosity       (Verbosity)-import           Distribution.Version         (Version)-import           Prelude ()-import           System.Directory             (doesFileExist)--#if MIN_VERSION_base(4,10,0)-import Control.Applicative (Applicative (..))-#endif---- | A monad with failure and accumulating errors and warnings.-newtype ParseResult a = PR-    { unPR-        :: forall r. PRState-        -> (PRState -> r) -- failure, but we were able to recover a new-style spec-version declaration-        -> (PRState -> a -> r)             -- success-        -> r-    }---- Note: we have version here, as we could get any version.-data PRState = PRState ![PWarning] ![PError] !(Maybe Version)--emptyPRState :: PRState-emptyPRState = PRState [] [] Nothing---- | Forget 'ParseResult's warnings.------ @since 3.4.0.0-withoutWarnings :: ParseResult a -> ParseResult a-withoutWarnings m = PR $ \s failure success ->-    unPR m s failure $ \ !s1 -> success (s1 `withWarningsOf` s)-  where-    withWarningsOf (PRState _ e v) (PRState w _ _) = PRState w e v---- | Destruct a 'ParseResult' into the emitted warnings and either--- a successful value or--- list of errors and possibly recovered a spec-version declaration.-runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, NonEmpty PError) a)-runParseResult pr = unPR pr emptyPRState failure success-  where-    failure (PRState warns []         v)   = (warns, Left (v, PError zeroPos "panic" :| []))-    failure (PRState warns (err:errs) v)   = (warns, Left (v, err :| errs)) where-    success (PRState warns []         _)   x = (warns, Right x)-    -- If there are any errors, don't return the result-    success (PRState warns (err:errs) v) _ = (warns, Left (v, err :| errs))--instance Functor ParseResult where-    fmap f (PR pr) = PR $ \ !s failure success ->-        pr s failure $ \ !s' a ->-        success s' (f a)-    {-# INLINE fmap #-}--instance Applicative ParseResult where-    pure x = PR $ \ !s _ success -> success s x-    {-# INLINE pure #-}--    f <*> x = PR $ \ !s0 failure success ->-        unPR f s0 failure $ \ !s1 f' ->-        unPR x s1 failure $ \ !s2 x' ->-        success s2 (f' x')-    {-# INLINE (<*>) #-}--    x  *> y = PR $ \ !s0 failure success ->-        unPR x s0 failure $ \ !s1 _ ->-        unPR y s1 failure success-    {-# INLINE (*>) #-}--    x  <* y = PR $ \ !s0 failure success ->-        unPR x s0 failure $ \ !s1 x' ->-        unPR y s1 failure $ \ !s2 _  ->-        success s2 x'-    {-# INLINE (<*) #-}--#if MIN_VERSION_base(4,10,0)-    liftA2 f x y = PR $ \ !s0 failure success ->-        unPR x s0 failure $ \ !s1 x' ->-        unPR y s1 failure $ \ !s2 y' ->-        success s2 (f x' y')-    {-# INLINE liftA2 #-}-#endif--instance Monad ParseResult where-    return = pure-    (>>) = (*>)--    m >>= k = PR $ \ !s failure success ->-        unPR m s failure $ \ !s' a ->-        unPR (k a) s' failure success-    {-# INLINE (>>=) #-}---- | "Recover" the parse result, so we can proceed parsing.--- 'runParseResult' will still result in 'Nothing', if there are recorded errors.-recoverWith :: ParseResult a -> a -> ParseResult a-recoverWith (PR pr) x = PR $ \ !s _failure success ->-    pr s (\ !s' -> success s' x) success---- | Set cabal spec version.-setCabalSpecVersion :: Maybe Version -> ParseResult ()-setCabalSpecVersion v = PR $ \(PRState warns errs _) _failure success ->-    success (PRState warns errs v) ()---- | Get cabal spec version.-getCabalSpecVersion :: ParseResult (Maybe Version)-getCabalSpecVersion = PR $ \s@(PRState _ _ v) _failure success ->-    success s v---- | Add a warning. This doesn't fail the parsing process.-parseWarning :: Position -> PWarnType -> String -> ParseResult ()-parseWarning pos t msg = PR $ \(PRState warns errs v) _failure success ->-    success (PRState (PWarning t pos msg : warns) errs v) ()---- | Add multiple warnings at once.-parseWarnings :: [PWarning] -> ParseResult ()-parseWarnings newWarns = PR $ \(PRState warns errs v) _failure success ->-    success (PRState (newWarns ++ warns) errs v) ()---- | Add an error, but not fail the parser yet.------ For fatal failure use 'parseFatalFailure'-parseFailure :: Position -> String -> ParseResult ()-parseFailure pos msg = PR $ \(PRState warns errs v) _failure success ->-    success (PRState warns (PError pos msg : errs) v) ()---- | Add an fatal error.-parseFatalFailure :: Position -> String -> ParseResult a-parseFatalFailure pos msg = PR $ \(PRState warns errs v) failure _success ->-    failure (PRState warns (PError pos msg : errs) v)---- | A 'mzero'.-parseFatalFailure' :: ParseResult a-parseFatalFailure' = PR pr-  where-    pr (PRState warns [] v) failure _success = failure (PRState warns [err] v)-    pr s                    failure _success = failure s--    err = PError zeroPos "Unknown fatal error"---- | Helper combinator to do parsing plumbing for files.------ Given a parser and a filename, return the parse of the file,--- after checking if the file exists.------ Argument order is chosen to encourage partial application.-readAndParseFile-    :: (BS.ByteString -> ParseResult a)  -- ^ File contents to final value parser-    -> Verbosity                         -- ^ Verbosity level-    -> FilePath                          -- ^ File to read-    -> IO a-readAndParseFile parser verbosity fpath = do-    exists <- doesFileExist fpath-    unless exists $-      die' verbosity $-        "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."-    bs <- BS.readFile fpath-    parseString parser verbosity fpath bs--parseString-    :: (BS.ByteString -> ParseResult a)  -- ^ File contents to final value parser-    -> Verbosity                         -- ^ Verbosity level-    -> String                            -- ^ File name-    -> BS.ByteString-    -> IO a-parseString parser verbosity name bs = do-    let (warnings, result) = runParseResult (parser bs)-    traverse_ (warn verbosity . showPWarning name) warnings-    case result of-        Right x -> return x-        Left (_, errors) -> do-            traverse_ (warn verbosity . showPError name) errors-            die' verbosity $ "Failed parsing \"" ++ name ++ "\"."
− src/Distribution/Fields/Parser.hs 
@@ -1,377 +0,0 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE PatternGuards         #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Fields.Parser--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable-module Distribution.Fields.Parser (-    -- * Types-    Field(..),-    Name(..),-    FieldLine(..),-    SectionArg(..),-    -- * Grammar and parsing-    -- $grammar-    readFields,-    readFields',-#ifdef CABAL_PARSEC_DEBUG-    -- * Internal-    parseFile,-    parseStr,-    parseBS,-#endif-    ) where--import qualified Data.ByteString.Char8          as B8-import           Data.Functor.Identity-import           Distribution.Compat.Prelude-import           Distribution.Fields.Field-import           Distribution.Fields.Lexer-import           Distribution.Fields.LexerMonad-                 (LexResult (..), LexState (..), LexWarning (..), unLex)-import           Distribution.Parsec.Position   (Position (..))-import           Prelude ()-import           Text.Parsec.Combinator         hiding (eof, notFollowedBy)-import           Text.Parsec.Error-import           Text.Parsec.Pos-import           Text.Parsec.Prim               hiding (many, (<|>))--#ifdef CABAL_PARSEC_DEBUG-import qualified Data.Text                as T-import qualified Data.Text.Encoding       as T-import qualified Data.Text.Encoding.Error as T-#endif---- | The 'LexState'' (with a prime) is an instance of parsec's 'Stream'--- wrapped around lexer's 'LexState' (without a prime)-data LexState' = LexState' !LexState (LToken, LexState')--mkLexState' :: LexState -> LexState'-mkLexState' st = LexState' st-                   (case unLex lexToken st of LexResult st' tok -> (tok, mkLexState' st'))--type Parser a = ParsecT LexState' () Identity a--instance Stream LexState' Identity LToken where-  uncons (LexState' _ (tok, st')) =-    case tok of-      L _ EOF -> return Nothing-      _       -> return (Just (tok, st'))---- | Get lexer warnings accumulated so far-getLexerWarnings :: Parser [LexWarning]-getLexerWarnings = do-  LexState' (LexState { warnings = ws }) _ <- getInput-  return ws---- | Set Alex code i.e. the mode "state" lexer is in.-setLexerMode :: Int -> Parser ()-setLexerMode code = do-  LexState' ls _ <- getInput-  setInput $! mkLexState' ls { curCode = code }--getToken :: (Token -> Maybe a) -> Parser a-getToken getTok = getTokenWithPos (\(L _ t) -> getTok t)--getTokenWithPos :: (LToken -> Maybe a) -> Parser a-getTokenWithPos getTok = tokenPrim (\(L _ t) -> describeToken t) updatePos getTok-  where-    updatePos :: SourcePos -> LToken -> LexState' -> SourcePos-    updatePos pos (L (Position col line) _) _ = newPos (sourceName pos) col line--describeToken :: Token -> String-describeToken t = case t of-  TokSym   s      -> "symbol "   ++ show s-  TokStr   s      -> "string "   ++ show s-  TokOther s      -> "operator " ++ show s-  Indent _        -> "new line"-  TokFieldLine _  -> "field content"-  Colon           -> "\":\""-  OpenBrace       -> "\"{\""-  CloseBrace      -> "\"}\""---  SemiColon       -> "\";\""-  EOF             -> "end of file"-  LexicalError is -> "character in input " ++ show (B8.head is)--tokSym :: Parser (Name Position)-tokSym', tokStr, tokOther :: Parser (SectionArg Position)-tokIndent :: Parser Int-tokColon, tokOpenBrace, tokCloseBrace :: Parser ()-tokFieldLine :: Parser (FieldLine Position)--tokSym        = getTokenWithPos $ \t -> case t of L pos (TokSym   x) -> Just (mkName pos x);  _ -> Nothing-tokSym'       = getTokenWithPos $ \t -> case t of L pos (TokSym   x) -> Just (SecArgName pos x);  _ -> Nothing-tokStr        = getTokenWithPos $ \t -> case t of L pos (TokStr   x) -> Just (SecArgStr pos x);  _ -> Nothing-tokOther      = getTokenWithPos $ \t -> case t of L pos (TokOther x) -> Just (SecArgOther pos x);  _ -> Nothing-tokIndent     = getToken $ \t -> case t of Indent   x -> Just x;  _ -> Nothing-tokColon      = getToken $ \t -> case t of Colon      -> Just (); _ -> Nothing-tokOpenBrace  = getToken $ \t -> case t of OpenBrace  -> Just (); _ -> Nothing-tokCloseBrace = getToken $ \t -> case t of CloseBrace -> Just (); _ -> Nothing-tokFieldLine  = getTokenWithPos $ \t -> case t of L pos (TokFieldLine s) -> Just (FieldLine pos s); _ -> Nothing--colon, openBrace, closeBrace :: Parser ()--sectionArg :: Parser (SectionArg Position)-sectionArg   = tokSym' <|> tokStr <|> tokOther <?> "section parameter"--fieldSecName :: Parser (Name Position)-fieldSecName = tokSym              <?> "field or section name"--colon        = tokColon      <?> "\":\""-openBrace    = tokOpenBrace  <?> "\"{\""-closeBrace   = tokCloseBrace <?> "\"}\""--fieldContent :: Parser (FieldLine Position)-fieldContent = tokFieldLine <?> "field contents"--newtype IndentLevel = IndentLevel Int--zeroIndentLevel :: IndentLevel-zeroIndentLevel = IndentLevel 0--incIndentLevel :: IndentLevel -> IndentLevel-incIndentLevel (IndentLevel i) = IndentLevel (succ i)--indentOfAtLeast :: IndentLevel -> Parser IndentLevel-indentOfAtLeast (IndentLevel i) = try $ do-  j <- tokIndent-  guard (j >= i) <?> "indentation of at least " ++ show i-  return (IndentLevel j)---newtype LexerMode = LexerMode Int--inLexerMode :: LexerMode -> Parser p -> Parser p-inLexerMode (LexerMode mode) p =-  do setLexerMode mode; x <- p; setLexerMode in_section; return x----------------------------- Cabal file grammar------- $grammar------ @--- CabalStyleFile ::= SecElems------ SecElems       ::= SecElem* '\\n'?--- SecElem        ::= '\\n' SecElemLayout | SecElemBraces--- SecElemLayout  ::= FieldLayout | FieldBraces | SectionLayout | SectionBraces--- SecElemBraces  ::= FieldInline | FieldBraces |                 SectionBraces--- FieldLayout    ::= name ':' line? ('\\n' line)*--- FieldBraces    ::= name ':' '\\n'? '{' content '}'--- FieldInline    ::= name ':' content--- SectionLayout  ::= name arg* SecElems--- SectionBraces  ::= name arg* '\\n'? '{' SecElems '}'--- @------ and the same thing but left factored...------ @--- SecElems              ::= SecElem*--- SecElem               ::= '\\n' name SecElemLayout---                         |      name SecElemBraces--- SecElemLayout         ::= ':'   FieldLayoutOrBraces---                         | arg*  SectionLayoutOrBraces--- FieldLayoutOrBraces   ::= '\\n'? '{' content '}'---                         | line? ('\\n' line)*--- SectionLayoutOrBraces ::= '\\n'? '{' SecElems '\\n'? '}'---                         | SecElems--- SecElemBraces         ::= ':' FieldInlineOrBraces---                         | arg* '\\n'? '{' SecElems '\\n'? '}'--- FieldInlineOrBraces   ::= '\\n'? '{' content '}'---                         | content--- @------ Note how we have several productions with the sequence:------ > '\\n'? '{'------ That is, an optional newline (and indent) followed by a @{@ token.--- In the @SectionLayoutOrBraces@ case you can see that this makes it--- not fully left factored (because @SecElems@ can start with a @\\n@).--- Fully left factoring here would be ugly, and though we could use a--- lookahead of two tokens to resolve the alternatives, we can't--- conveniently use Parsec's 'try' here to get a lookahead of only two.--- So instead we deal with this case in the lexer by making a line--- where the first non-space is @{@ lex as just the @{@ token, without--- the usual indent token. Then in the parser we can resolve everything--- with just one token of lookahead and so without using 'try'.---- Top level of a file using cabal syntax----cabalStyleFile :: Parser [Field Position]-cabalStyleFile = do es <- elements zeroIndentLevel-                    eof-                    return es---- Elements that live at the top level or inside a section, ie fields--- and sectionscontent------ elements ::= element*-elements :: IndentLevel -> Parser [Field Position]-elements ilevel = many (element ilevel)---- An individual element, ie a field or a section. These can either use--- layout style or braces style. For layout style then it must start on--- a line on its own (so that we know its indentation level).------ element ::= '\\n' name elementInLayoutContext---           |      name elementInNonLayoutContext-element :: IndentLevel -> Parser (Field Position)-element ilevel =-      (do ilevel' <- indentOfAtLeast ilevel-          name    <- fieldSecName-          elementInLayoutContext (incIndentLevel ilevel') name)-  <|> (do name    <- fieldSecName-          elementInNonLayoutContext name)---- An element (field or section) that is valid in a layout context.--- In a layout context we can have fields and sections that themselves--- either use layout style or that use braces style.------ elementInLayoutContext ::= ':'  fieldLayoutOrBraces---                          | arg* sectionLayoutOrBraces-elementInLayoutContext :: IndentLevel -> Name Position -> Parser (Field Position)-elementInLayoutContext ilevel name =-      (do colon; fieldLayoutOrBraces ilevel name)-  <|> (do args  <- many sectionArg-          elems <- sectionLayoutOrBraces ilevel-          return (Section name args elems))---- An element (field or section) that is valid in a non-layout context.--- In a non-layout context we can have only have fields and sections that--- themselves use braces style, or inline style fields.------ elementInNonLayoutContext ::= ':' FieldInlineOrBraces---                             | arg* '\\n'? '{' elements '\\n'? '}'-elementInNonLayoutContext :: Name Position -> Parser (Field Position)-elementInNonLayoutContext name =-      (do colon; fieldInlineOrBraces name)-  <|> (do args <- many sectionArg-          openBrace-          elems <- elements zeroIndentLevel-          optional tokIndent-          closeBrace-          return (Section name args elems))---- The body of a field, using either layout style or braces style.------ fieldLayoutOrBraces   ::= '\\n'? '{' content '}'---                         | line? ('\\n' line)*-fieldLayoutOrBraces :: IndentLevel -> Name Position -> Parser (Field Position)-fieldLayoutOrBraces ilevel name = braces <|> fieldLayout-  where-    braces = do-          openBrace-          ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent)-          closeBrace-          return (Field name ls)-    fieldLayout = inLexerMode (LexerMode in_field_layout) $ do-          l  <- optionMaybe fieldContent-          ls <- many (do _ <- indentOfAtLeast ilevel; fieldContent)-          return $ case l of-              Nothing -> Field name ls-              Just l' -> Field name (l' : ls)---- The body of a section, using either layout style or braces style.------ sectionLayoutOrBraces ::= '\\n'? '{' elements \\n? '}'---                         | elements-sectionLayoutOrBraces :: IndentLevel -> Parser [Field Position]-sectionLayoutOrBraces ilevel =-      (do openBrace-          elems <- elements zeroIndentLevel-          optional tokIndent-          closeBrace-          return elems)-  <|> (elements ilevel)---- The body of a field, using either inline style or braces.------ fieldInlineOrBraces   ::= '\\n'? '{' content '}'---                         | content-fieldInlineOrBraces :: Name Position -> Parser (Field Position)-fieldInlineOrBraces name =-      (do openBrace-          ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent)-          closeBrace-          return (Field name ls))-  <|> (do ls <- inLexerMode (LexerMode in_field_braces) (option [] (fmap (\l -> [l]) fieldContent))-          return (Field name ls))----- | Parse cabal style 'B8.ByteString' into list of 'Field's, i.e. the cabal AST.-readFields :: B8.ByteString -> Either ParseError [Field Position]-readFields s = fmap fst (readFields' s)---- | Like 'readFields' but also return lexer warnings-readFields' :: B8.ByteString -> Either ParseError ([Field Position], [LexWarning])-readFields' s = do-    parse parser "the input" lexSt-  where-    parser = do-        fields <- cabalStyleFile-        ws     <- getLexerWarnings-        pure (fields, ws)--    lexSt = mkLexState' (mkLexState s)--#ifdef CABAL_PARSEC_DEBUG-parseTest' :: Show a => Parsec LexState' () a -> SourceName -> B8.ByteString -> IO ()-parseTest' p fname s =-    case parse p fname (lexSt s) of-      Left err -> putStrLn (formatError s err)--      Right x  -> print x-  where-    lexSt = mkLexState' . mkLexState--parseFile :: Show a => Parser a -> FilePath -> IO ()-parseFile p f = B8.readFile f >>= \s -> parseTest' p f s--parseStr  :: Show a => Parser a -> String -> IO ()-parseStr p = parseBS p . B8.pack--parseBS  :: Show a => Parser a -> B8.ByteString -> IO ()-parseBS p = parseTest' p "<input string>"--formatError :: B8.ByteString -> ParseError -> String-formatError input perr =-    unlines-      [ "Parse error "++ show (errorPos perr) ++ ":"-      , errLine-      , indicator ++ errmsg ]-  where-    pos       = errorPos perr-    ls        = lines' (T.decodeUtf8With T.lenientDecode input)-    errLine   = T.unpack (ls !! (sourceLine pos - 1))-    indicator = replicate (sourceColumn pos) ' ' ++ "^"-    errmsg    = showErrorMessages "or" "unknown parse error"-                                  "expecting" "unexpected" "end of file"-                                  (errorMessages perr)---- | Handles windows/osx/unix line breaks uniformly-lines' :: T.Text -> [T.Text]-lines' s1-  | T.null s1 = []-  | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of-                  (l, s2) | Just (c,s3) <- T.uncons s2-                         -> case T.uncons s3 of-                              Just ('\n', s4) | c == '\r' -> l : lines' s4-                              _               -> l : lines' s3-                          | otherwise -> [l]-#endif--eof :: Parser ()-eof = notFollowedBy anyToken <?> "end of file"-  where-    notFollowedBy :: Parser LToken -> Parser ()-    notFollowedBy p = try (    (do L _ t <- try p; unexpected (describeToken t))-                           <|> return ())
− src/Distribution/Fields/Pretty.hs 
@@ -1,176 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}--- | Cabal-like file AST types: 'Field', 'Section' etc,------ This (intermediate) data type is used for pretty-printing.------ @since 3.0.0.0----module Distribution.Fields.Pretty (-    -- * Fields-    PrettyField (..),-    showFields,-    showFields',-    -- * Transformation from 'P.Field'-    fromParsecFields,-    genericFromParsecFields,-    prettyFieldLines,-    prettySectionArgs,-    ) where--import Distribution.Compat.Prelude-import Distribution.Pretty         (showToken)-import Prelude ()--import Distribution.Fields.Field (FieldName)-import Distribution.Simple.Utils (fromUTF8BS)--import qualified Distribution.Fields.Parser as P--import qualified Data.ByteString  as BS-import qualified Text.PrettyPrint as PP--data PrettyField ann-    = PrettyField ann FieldName PP.Doc-    | PrettySection ann FieldName [PP.Doc] [PrettyField ann]-  deriving (Functor, Foldable, Traversable)---- | Prettyprint a list of fields.------ Note: the first argument should return 'String's without newlines--- and properly prefixes (with @--@) to count as comments.--- This unsafety is left in place so one could generate empty lines--- between comment lines.----showFields :: (ann -> [String]) -> [PrettyField ann] -> String-showFields rann = showFields' rann (const id) 4---- | 'showFields' with user specified indentation.-showFields'-  :: (ann -> [String])-     -- ^ Convert an annotation to lined to preceed the field or section.-  -> (ann -> [String] -> [String])-     -- ^ Post-process non-annotation produced lines.-  -> Int-     -- ^ Indentation level.-  -> [PrettyField ann]-     -- ^ Fields/sections to show.-  -> String-showFields' rann post n = unlines . renderFields (Opts rann indent post)-  where-    -- few hardcoded, "unrolled"  variants.-    indent | n == 4    = indent4-           | n == 2    = indent2-           | otherwise = (replicate (max n 1) ' ' ++)--    indent4 :: String -> String-    indent4 [] = []-    indent4 xs = ' ' : ' ' : ' ' : ' ' : xs--    indent2 :: String -> String-    indent2 [] = []-    indent2 xs = ' ' : ' ' : xs--data Opts ann = Opts-  { _optAnnotation ::(ann -> [String])-  , _optIndent ::(String -> String)-  , _optPostprocess :: ann -> [String] -> [String]-  }--renderFields :: Opts ann -> [PrettyField ann] -> [String]-renderFields opts fields = flattenBlocks $ map (renderField opts len) fields-  where-    len = maxNameLength 0 fields--    maxNameLength !acc []                            = acc-    maxNameLength !acc (PrettyField _ name _ : rest) = maxNameLength (max acc (BS.length name)) rest-    maxNameLength !acc (PrettySection {}   : rest)   = maxNameLength acc rest---- | Block of lines,--- Boolean parameter tells whether block should be surrounded by empty lines-data Block = Block Margin Margin [String]--data Margin = Margin | NoMargin-  deriving Eq---- | Collapse margins, any margin = margin-instance Semigroup Margin where-    NoMargin <> NoMargin = NoMargin-    _        <> _        = Margin--flattenBlocks :: [Block] -> [String]-flattenBlocks = go0 where-    go0 [] = []-    go0 (Block _before after strs : blocks) = strs ++ go after blocks--    go _surr' [] = []-    go  surr' (Block before after strs : blocks) = ins $ strs ++ go after blocks where-        ins | surr' <> before == Margin = ("" :)-            | otherwise                 = id--renderField :: Opts ann -> Int -> PrettyField ann -> Block-renderField (Opts rann indent post) fw (PrettyField ann name doc) =-    Block before after $ comments ++ post ann lines'-  where-    comments = rann ann-    before = if null comments then NoMargin else Margin--    (lines', after) = case lines narrow of-        []           -> ([ name' ++ ":" ], NoMargin)-        [singleLine] | length singleLine < 60-                     -> ([ name' ++ ": " ++ replicate (fw - length name') ' ' ++ narrow ], NoMargin)-        _            -> ((name' ++ ":") : map indent (lines (PP.render doc)), Margin)--    name' = fromUTF8BS name-    narrow = PP.renderStyle narrowStyle doc--    narrowStyle :: PP.Style-    narrowStyle = PP.style { PP.lineLength = PP.lineLength PP.style - fw }--renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields) = Block Margin Margin $-    rann ann-    ++-    post ann [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ]-    ++-    (map indent $ renderFields opts fields)------------------------------------------------------------------------------------ Transform from Parsec.Field----------------------------------------------------------------------------------genericFromParsecFields-    :: Applicative f-    => (FieldName -> [P.FieldLine ann] -> f PP.Doc)     -- ^ transform field contents-    -> (FieldName -> [P.SectionArg ann] -> f [PP.Doc])  -- ^ transform section arguments-    -> [P.Field ann]-    -> f [PrettyField ann]-genericFromParsecFields f g = goMany where-    goMany = traverse go--    go (P.Field (P.Name ann name) fls)          = PrettyField ann name <$> f name fls-    go (P.Section (P.Name ann name) secargs fs) = PrettySection ann name <$> g name secargs <*> goMany fs---- | Used in 'fromParsecFields'.-prettyFieldLines :: FieldName -> [P.FieldLine ann] -> PP.Doc-prettyFieldLines _ fls = PP.vcat-    [ PP.text $ fromUTF8BS bs-    | P.FieldLine _ bs <- fls-    ]---- | Used in 'fromParsecFields'.-prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc]-prettySectionArgs _ = map $ \sa -> case sa of-    P.SecArgName _ bs  -> showToken $ fromUTF8BS bs-    P.SecArgStr _ bs   -> showToken $ fromUTF8BS bs-    P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs---- | Simple variant of 'genericFromParsecField'-fromParsecFields :: [P.Field ann] -> [PrettyField ann]-fromParsecFields = runIdentity . genericFromParsecFields-    (Identity .: prettyFieldLines)-    (Identity .: prettySectionArgs)-  where-    (.:) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b)-    (f .: g) x y = f (g x y)
src/Distribution/GetOpt.hs view
@@ -1,4 +1,8 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TupleSections #-}+ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.GetOpt -- Copyright   :  (c) Sven Panne 2002-2005@@ -17,54 +21,87 @@ -- * Line wrapping in the 'usageInfo' output, plus a more compact --   rendering of short options, and slightly less padding. ----- If you want to take on the challenge of merging this with the GetOpt--- from the base package then go for it!+-- * Parsing of option arguments is allowed to fail. ---{-# LANGUAGE TupleSections #-}-{-# LANGUAGE NamedFieldPuns #-}-module Distribution.GetOpt (-   -- * GetOpt-   getOpt, getOpt',-   usageInfo,-   ArgOrder(..),-   OptDescr(..),-   ArgDescr(..),+-- * 'ReturnInOrder' argument order is removed.+module Distribution.GetOpt+  ( -- * GetOpt+    getOpt+  , getOpt'+  , usageInfo+  , ArgOrder (..)+  , OptDescr (..)+  , ArgDescr (..) -   -- * Example-   -- | See "System.Console.GetOpt" for examples-) where+    -- * Example -import Prelude ()+    -- | See "System.Console.GetOpt" for examples+  ) where+ import Distribution.Compat.Prelude-import System.Console.GetOpt-         ( ArgOrder(..), OptDescr(..), ArgDescr(..) )+import Prelude () -data OptKind a                -- kind of cmd line arg (internal use only):-   = Opt       a                --    an option-   | UnreqOpt  String           --    an un-recognized option-   | NonOpt    String           --    a non-option-   | EndOfOpts                  --    end-of-options marker (i.e. "--")-   | OptErr    String           --    something went wrong...+-- | What to do with options following non-options+data ArgOrder a+  = -- | no option processing after first non-option+    RequireOrder+  | -- | freely intersperse options and non-options+    Permute -data OptHelp a = OptHelp {-      optNames :: a,-      optHelp :: String-    }+data OptDescr a -- description of a single options:+  = Option+      [Char] --    list of short option characters+      [String] --    list of long option strings (without "--")+      (ArgDescr a) --    argument descriptor+      String --    explanation of option for user +instance Functor OptDescr where+  fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c++-- | Describes whether an option takes an argument or not, and if so+-- how the argument is parsed to a value of type @a@.+--+-- Compared to System.Console.GetOpt, we allow for parse errors.+data ArgDescr a+  = -- |   no argument expected+    NoArg a+  | -- |   option requires argument+    ReqArg (String -> Either String a) String+  | -- |   optional argument+    OptArg String (Maybe String -> Either String a) String++instance Functor ArgDescr where+  fmap f (NoArg a) = NoArg (f a)+  fmap f (ReqArg g s) = ReqArg (fmap f . g) s+  fmap f (OptArg dv g s) = OptArg dv (fmap f . g) s++data OptKind a -- kind of cmd line arg (internal use only):+  = Opt a --    an option+  | UnreqOpt String --    an un-recognized option+  | NonOpt String --    a non-option+  | EndOfOpts --    end-of-options marker (i.e. "--")+  | OptErr String --    something went wrong...++data OptHelp = OptHelp+  { optNames :: String+  , optHelp :: String+  }+ -- | Return a string describing the usage of a command, derived from -- the header (first argument) and the options described by the -- second argument.-usageInfo :: String                    -- header-          -> [OptDescr a]              -- option descriptors-          -> String                    -- nicely formatted decription of options+usageInfo+  :: String -- header+  -> [OptDescr a] -- option descriptors+  -> String -- nicely formatted description of options usageInfo header optDescr = unlines (header : table)   where     options = flip map optDescr $ \(Option sos los ad d) ->       OptHelp         { optNames =-          intercalate ", " $-            map (fmtShort ad) sos ++-            map (fmtLong  ad) (take 1 los)+            intercalate ", " $+              map (fmtShort ad) sos+                ++ map (fmtLong ad) (take 1 los)         , optHelp = d         } @@ -76,8 +113,9 @@       OptHelp{optNames, optHelp} <- options       let wrappedHelp = wrapText descolWidth optHelp       if length optNames >= maxOptNameWidth-        then [" " ++ optNames] ++-             renderColumns [] wrappedHelp+        then+          [" " ++ optNames]+            ++ renderColumns [] wrappedHelp         else renderColumns [optNames] wrappedHelp      renderColumns :: [String] -> [String] -> [String]@@ -85,141 +123,179 @@       (x, y) <- zipDefault "" "" xs ys       return $ " " ++ padTo maxOptNameWidth x ++ " " ++ y -    padTo n x  = take n (x ++ repeat ' ')+    padTo n x = take n (x ++ repeat ' ') -zipDefault :: a -> b -> [a] -> [b] -> [(a,b)]-zipDefault _  _  []     []     = []-zipDefault _  bd (a:as) []     = (a,bd) : map (,bd) as-zipDefault ad _  []     (b:bs) = (ad,b) : map (ad,) bs-zipDefault ad bd (a:as) (b:bs) = (a,b)  : zipDefault ad bd as bs+zipDefault :: a -> b -> [a] -> [b] -> [(a, b)]+zipDefault _ _ [] [] = []+zipDefault _ bd (a : as) [] = (a, bd) : map (,bd) as+zipDefault ad _ [] (b : bs) = (ad, b) : map (ad,) bs+zipDefault ad bd (a : as) (b : bs) = (a, b) : zipDefault ad bd as bs +-- | Pretty printing of short options.+-- * With required arguments can be given as:+--    @-w PATH or -wPATH (but not -w=PATH)@+--   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 displayed as:+--    @-j[NUM]@ fmtShort :: ArgDescr a -> Char -> String-fmtShort (NoArg  _   ) so = "-" ++ [so]-fmtShort (ReqArg _  _) so = "-" ++ [so]-fmtShort (OptArg _  _) so = "-" ++ [so]-  -- unlike upstream GetOpt we omit the arg name for short options+fmtShort (NoArg _) so = "-" ++ [so]+fmtShort (ReqArg _ ad) so =+  let opt = "-" ++ [so]+   in opt ++ " " ++ ad ++ " or " ++ opt ++ ad+fmtShort (OptArg _ _ ad) so =+  let opt = "-" ++ [so]+   in opt ++ "[" ++ ad ++ "]" +-- | Pretty printing of long options.+-- * With required arguments can be given as:+--    @--with-compiler=PATH (but not --with-compiler PATH)@+--   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 displayed as:+--    @--jobs[=NUM]@ fmtLong :: ArgDescr a -> String -> String-fmtLong (NoArg  _   ) lo = "--" ++ lo-fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad-fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"+fmtLong (NoArg _) lo = "--" ++ lo+fmtLong (ReqArg _ ad) lo =+  let opt = "--" ++ lo+   in opt ++ "=" ++ ad+fmtLong (OptArg _ _ ad) lo =+  let opt = "--" ++ lo+   in opt ++ "[=" ++ ad ++ "]"  wrapText :: Int -> String -> [String] wrapText width = map unwords . wrap 0 [] . words-  where wrap :: Int -> [String] -> [String] -> [[String]]-        wrap 0   []   (w:ws)-          | length w + 1 > width-          = wrap (length w) [w] ws-        wrap col line (w:ws)-          | col + length w + 1 > width-          = reverse line : wrap 0 [] (w:ws)-        wrap col line (w:ws)-          = let col' = col + length w + 1-             in wrap col' (w:line) ws-        wrap _ []   [] = []-        wrap _ line [] = [reverse line]--{-|-Process the command-line, and return the list of values that matched-(and those that didn\'t). The arguments are:--* The order requirements (see 'ArgOrder')--* The option descriptions (see 'OptDescr')--* The actual command line arguments (presumably got from-  'System.Environment.getArgs').+  where+    wrap :: Int -> [String] -> [String] -> [[String]]+    wrap 0 [] (w : ws)+      | length w + 1 > width =+          wrap (length w) [w] ws+    wrap col line (w : ws)+      | col + length w + 1 > width =+          reverse line : wrap 0 [] (w : ws)+    wrap col line (w : ws) =+      let col' = col + length w + 1+       in wrap col' (w : line) ws+    wrap _ [] [] = []+    wrap _ line [] = [reverse line] -'getOpt' returns a triple consisting of the option arguments, a list-of non-options, and a list of error messages.--}-getOpt :: ArgOrder a                   -- non-option handling-       -> [OptDescr a]                 -- option descriptors-       -> [String]                     -- the command-line arguments-       -> ([a],[String],[String])      -- (options,non-options,error messages)-getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)-   where (os,xs,us,es) = getOpt' ordering optDescr args+-- |+-- Process the command-line, and return the list of values that matched+-- (and those that didn\'t). The arguments are:+--+-- * The order requirements (see 'ArgOrder')+--+-- * The option descriptions (see 'OptDescr')+--+-- * The actual command line arguments (presumably got from+--   'System.Environment.getArgs').+--+-- 'getOpt' returns a triple consisting of the option arguments, a list+-- of non-options, and a list of error messages.+getOpt+  :: ArgOrder a -- non-option handling+  -> [OptDescr a] -- option descriptors+  -> [String] -- the command-line arguments+  -> ([a], [String], [String]) -- (options,non-options,error messages)+getOpt ordering optDescr args = (os, xs, es ++ map errUnrec us)+  where+    (os, xs, us, es) = getOpt' ordering optDescr args -{-|-This is almost the same as 'getOpt', but returns a quadruple-consisting of the option arguments, a list of non-options, a list of-unrecognized options, and a list of error messages.--}-getOpt' :: ArgOrder a                         -- non-option handling-        -> [OptDescr a]                       -- option descriptors-        -> [String]                           -- the command-line arguments-        -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)-getOpt' _        _        []         =  ([],[],[],[])-getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering-   where procNextOpt (Opt o)      _                 = (o:os,xs,us,es)-         procNextOpt (UnreqOpt u) _                 = (os,xs,u:us,es)-         procNextOpt (NonOpt x)   RequireOrder      = ([],x:rest,[],[])-         procNextOpt (NonOpt x)   Permute           = (os,x:xs,us,es)-         procNextOpt (NonOpt x)   (ReturnInOrder f) = (f x :os, xs,us,es)-         procNextOpt EndOfOpts    RequireOrder      = ([],rest,[],[])-         procNextOpt EndOfOpts    Permute           = ([],rest,[],[])-         procNextOpt EndOfOpts    (ReturnInOrder f) = (map f rest,[],[],[])-         procNextOpt (OptErr e)   _                 = (os,xs,us,e:es)+-- |+-- This is almost the same as 'getOpt', but returns a quadruple+-- consisting of the option arguments, a list of non-options, a list of+-- unrecognized options, and a list of error messages.+getOpt'+  :: ArgOrder a -- non-option handling+  -> [OptDescr a] -- option descriptors+  -> [String] -- the command-line arguments+  -> ([a], [String], [String], [String]) -- (options,non-options,unrecognized,error messages)+getOpt' _ _ [] = ([], [], [], [])+getOpt' ordering optDescr (arg : args) = procNextOpt opt ordering+  where+    procNextOpt (Opt o) _ = (o : os, xs, us, es)+    procNextOpt (UnreqOpt u) _ = (os, xs, u : us, es)+    procNextOpt (NonOpt x) RequireOrder = ([], x : rest, [], [])+    procNextOpt (NonOpt x) Permute = (os, x : xs, us, es)+    procNextOpt EndOfOpts RequireOrder = ([], rest, [], [])+    procNextOpt EndOfOpts Permute = ([], rest, [], [])+    procNextOpt (OptErr e) _ = (os, xs, us, e : es) -         (opt,rest) = getNext arg args optDescr-         (os,xs,us,es) = getOpt' ordering optDescr rest+    (opt, rest) = getNext arg args optDescr+    (os, xs, us, es) = getOpt' ordering optDescr rest  -- take a look at the next cmd line arg and decide what to do with it-getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])-getNext ('-':'-':[]) rest _        = (EndOfOpts,rest)-getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr-getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr-getNext a            rest _        = (NonOpt a,rest)+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a, [String])+getNext ('-' : '-' : []) rest _ = (EndOfOpts, rest)+getNext ('-' : '-' : xs) rest optDescr = longOpt xs rest optDescr+getNext ('-' : x : xs) rest optDescr = shortOpt x xs rest optDescr+getNext a rest _ = (NonOpt a, rest)  -- handle long option-longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a, [String]) longOpt ls rs optDescr = long ads arg rs-   where (opt,arg) = break (=='=') ls-         getWith p = [ o  | o@(Option _ xs _ _) <- optDescr-                          , isJust (find (p opt) xs)]-         exact     = getWith (==)-         options   = if null exact then getWith isPrefixOf else exact-         ads       = [ ad | Option _ _ ad _ <- options ]-         optStr    = "--" ++ opt+  where+    (opt, arg) = break (== '=') ls+    getWith p =+      [ o | o@(Option _ xs _ _) <- optDescr, isJust (find (p opt) xs)+      ]+    exact = getWith (==)+    options = if null exact then getWith isPrefixOf else exact+    ads = [ad | Option _ _ ad _ <- options]+    optStr = "--" ++ opt+    fromRes = fromParseResult optStr -         long (_:_:_)      _        rest     = (errAmbig options optStr,rest)-         long [NoArg  a  ] []       rest     = (Opt a,rest)-         long [NoArg  _  ] ('=':_)  rest     = (errNoArg optStr,rest)-         long [ReqArg _ d] []       []       = (errReq d optStr,[])-         long [ReqArg f _] []       (r:rest) = (Opt (f r),rest)-         long [ReqArg f _] ('=':xs) rest     = (Opt (f xs),rest)-         long [OptArg f _] []       rest     = (Opt (f Nothing),rest)-         long [OptArg f _] ('=':xs) rest     = (Opt (f (Just xs)),rest)-         long _            _        rest     = (UnreqOpt ("--"++ls),rest)+    long (_ : _ : _) _ rest = (errAmbig options optStr, rest)+    long [NoArg a] [] rest = (Opt a, rest)+    long [NoArg _] ('=' : _) rest = (errNoArg optStr, rest)+    long [ReqArg _ d] [] [] = (errReq d optStr, [])+    long [ReqArg f _] [] (r : rest) = (fromRes (f r), rest)+    long [ReqArg f _] ('=' : xs) rest = (fromRes (f xs), rest)+    long [OptArg _ f _] [] rest = (fromRes (f Nothing), rest)+    long [OptArg _ f _] ('=' : xs) rest = (fromRes (f (Just xs)), rest)+    long _ _ rest = (UnreqOpt ("--" ++ ls), rest)  -- handle short option-shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a, [String]) shortOpt y ys rs optDescr = short ads ys rs-  where options = [ o  | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]-        ads     = [ ad | Option _ _ ad _ <- options ]-        optStr  = '-':[y]+  where+    options = [o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s]+    ads = [ad | Option _ _ ad _ <- options]+    optStr = '-' : [y]+    fromRes = fromParseResult optStr -        short (_:_:_)        _  rest     = (errAmbig options optStr,rest)-        short (NoArg  a  :_) [] rest     = (Opt a,rest)-        short (NoArg  a  :_) xs rest     = (Opt a,('-':xs):rest)-        short (ReqArg _ d:_) [] []       = (errReq d optStr,[])-        short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)-        short (ReqArg f _:_) xs rest     = (Opt (f xs),rest)-        short (OptArg f _:_) [] rest     = (Opt (f Nothing),rest)-        short (OptArg f _:_) xs rest     = (Opt (f (Just xs)),rest)-        short []             [] rest     = (UnreqOpt optStr,rest)-        short []             xs rest     = (UnreqOpt (optStr++xs),rest)-        -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest)-        -- Apparently this was part of the change so that flags that are-        -- not recognised as global flags are passed on to the sub-command.-        -- But why was no equivalent change required for longOpt? So could-        -- this change go upstream?+    short (_ : _ : _) _ rest = (errAmbig options optStr, rest)+    short (NoArg a : _) [] rest = (Opt a, rest)+    short (NoArg a : _) xs rest = (Opt a, ('-' : xs) : rest)+    short (ReqArg _ d : _) [] [] = (errReq d optStr, [])+    short (ReqArg f _ : _) [] (r : rest) = (fromRes (f r), rest)+    short (ReqArg f _ : _) xs rest = (fromRes (f xs), rest)+    short (OptArg _ f _ : _) [] rest = (fromRes (f Nothing), rest)+    short (OptArg _ f _ : _) xs rest = (fromRes (f (Just xs)), rest)+    short [] [] rest = (UnreqOpt optStr, rest)+    short [] xs rest = (UnreqOpt (optStr ++ xs), rest) +-- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest)+-- Apparently this was part of the change so that flags that are+-- not recognised as global flags are passed on to the sub-command.+-- But why was no equivalent change required for longOpt? So could+-- this change go upstream?++fromParseResult :: String -> Either String a -> OptKind a+fromParseResult optStr res = case res of+  Right x -> Opt x+  Left err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n")+ -- miscellaneous error formatting -errAmbig :: [OptDescr a] -> String -> OptKind a+errAmbig :: [OptDescr a] -> String -> OptKind b errAmbig ods optStr = OptErr (usageInfo header ods)-   where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"+  where+    header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"  errReq :: String -> String -> OptKind a errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
− src/Distribution/InstalledPackageInfo.hs 
@@ -1,145 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.InstalledPackageInfo--- Copyright   :  (c) The University of Glasgow 2004------ Maintainer  :  libraries@haskell.org--- Portability :  portable------ This is the information about an /installed/ package that--- is communicated to the @ghc-pkg@ program in order to register--- a package.  @ghc-pkg@ now consumes this package format (as of version--- 6.4). This is specific to GHC at the moment.------ The @.cabal@ file format is for describing a package that is not yet--- installed. It has a lot of flexibility, like conditionals and dependency--- ranges. As such, that format is not at all suitable for describing a package--- that has already been built and installed. By the time we get to that stage,--- we have resolved all conditionals and resolved dependency version--- constraints to exact versions of dependent packages. So, this module defines--- the 'InstalledPackageInfo' data structure that contains all the info we keep--- about an installed package. There is a parser and pretty printer. The--- textual format is rather simpler than the @.cabal@ format: there are no--- sections, for example.---- This module is meant to be local-only to Distribution...--module Distribution.InstalledPackageInfo (-        InstalledPackageInfo(..),-        installedComponentId,-        installedOpenUnitId,-        sourceComponentName,-        requiredSignatures,-        ExposedModule(..),-        AbiDependency(..),-        emptyInstalledPackageInfo,-        parseInstalledPackageInfo,-        showInstalledPackageInfo,-        showFullInstalledPackageInfo,-        showInstalledPackageInfoField,-        showSimpleInstalledPackageInfoField,-  ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Backpack-import Distribution.CabalSpecVersion         (cabalSpecLatest)-import Distribution.FieldGrammar-import Distribution.FieldGrammar.FieldDescrs-import Distribution.ModuleName-import Distribution.Package                  hiding (installedUnitId)-import Distribution.Types.ComponentName-import Distribution.Utils.Generic            (toUTF8BS)--import Data.ByteString (ByteString)--import qualified Data.Map            as Map-import qualified Distribution.Fields as P-import qualified Text.PrettyPrint    as Disp--import Distribution.Types.InstalledPackageInfo-import Distribution.Types.InstalledPackageInfo.FieldGrammar---- $setup--- >>> :set -XOverloadedStrings--installedComponentId :: InstalledPackageInfo -> ComponentId-installedComponentId ipi =-    case unComponentId (installedComponentId_ ipi) of-        "" -> mkComponentId (unUnitId (installedUnitId ipi))-        _  -> installedComponentId_ ipi---- | Get the indefinite unit identity representing this package.--- This IS NOT guaranteed to give you a substitution; for--- instantiated packages you will get @DefiniteUnitId (installedUnitId ipi)@.--- For indefinite libraries, however, you will correctly get--- an @OpenUnitId@ with the appropriate 'OpenModuleSubst'.-installedOpenUnitId :: InstalledPackageInfo -> OpenUnitId-installedOpenUnitId ipi-    = mkOpenUnitId (installedUnitId ipi) (installedComponentId ipi) (Map.fromList (instantiatedWith ipi))---- | Returns the set of module names which need to be filled for--- an indefinite package, or the empty set if the package is definite.-requiredSignatures :: InstalledPackageInfo -> Set ModuleName-requiredSignatures ipi = openModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi))---- -------------------------------------------------------------------------------- Munging--sourceComponentName :: InstalledPackageInfo -> ComponentName-sourceComponentName = CLibName . sourceLibName---- -------------------------------------------------------------------------------- Parsing---- | Return either errors, or IPI with list of warnings-parseInstalledPackageInfo-    :: ByteString-    -> Either (NonEmpty String) ([String], InstalledPackageInfo)-parseInstalledPackageInfo s = case P.readFields s of-    Left err -> Left (show err :| [])-    Right fs -> case partitionFields fs of-        (fs', _) -> case P.runParseResult $ parseFieldGrammar cabalSpecLatest fs' ipiFieldGrammar of-            (ws, Right x) -> x `deepseq` Right (ws', x) where-                ws' = [ P.showPWarning "" w-                      | w@(P.PWarning wt _ _) <- ws-                      -- filter out warnings about experimental features-                      , wt /= P.PWTExperimental-                      ]-            (_,  Left (_, errs)) -> Left errs' where-                errs' = fmap (P.showPError "") errs---- -------------------------------------------------------------------------------- Pretty-printing---- | Pretty print 'InstalledPackageInfo'.------ @pkgRoot@ isn't printed, as ghc-pkg prints it manually (as GHC-8.4).-showInstalledPackageInfo :: InstalledPackageInfo -> String-showInstalledPackageInfo ipi =-    showFullInstalledPackageInfo ipi { pkgRoot = Nothing }---- | The variant of 'showInstalledPackageInfo' which outputs @pkgroot@ field too.-showFullInstalledPackageInfo :: InstalledPackageInfo -> String-showFullInstalledPackageInfo = P.showFields (const []) . prettyFieldGrammar cabalSpecLatest ipiFieldGrammar---- |------ >>> let ipi = emptyInstalledPackageInfo { maintainer = "Tester" }--- >>> fmap ($ ipi) $ showInstalledPackageInfoField "maintainer"--- Just "maintainer: Tester"-showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)-showInstalledPackageInfoField fn =-    fmap (\g -> Disp.render . ppField fn . g) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn)--showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)-showSimpleInstalledPackageInfoField fn =-    fmap (Disp.renderStyle myStyle .) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn)-  where-    myStyle = Disp.style { Disp.mode = Disp.LeftMode }--ppField :: String -> Disp.Doc -> Disp.Doc-ppField name fielddoc-     | Disp.isEmpty fielddoc = mempty-     | otherwise             = Disp.text name <<>> Disp.colon Disp.<+> fielddoc
src/Distribution/Lex.hs view
@@ -1,4 +1,5 @@ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Lex -- Copyright   :  Ben Gamari 2015-2019@@ -7,34 +8,43 @@ -- Portability :  portable -- -- This module contains a simple lexer supporting quoted strings--module Distribution.Lex (-        tokenizeQuotedWords- ) where+module Distribution.Lex+  ( tokenizeQuotedWords+  ) where -import Prelude ()-import Distribution.Compat.Prelude import Distribution.Compat.DList+import Distribution.Compat.Prelude+import Prelude () +-- | A simple parser supporting quoted strings.+--+-- Please be aware that this will only split strings when seeing whitespace+-- outside of quotation marks, i.e, @"foo\"bar baz\"qux quux"@ will be+-- converted to @["foobar bazqux", "quux"]@.+--+-- This behavior can be useful when parsing text like+-- @"ghc-options: -Wl,\"some option with spaces\""@, for instance. tokenizeQuotedWords :: String -> [String] tokenizeQuotedWords = filter (not . null) . go False mempty   where-    go :: Bool        -- ^ in quoted region-       -> DList Char  -- ^ accumulator-       -> String      -- ^ string to be parsed-       -> [String]    -- ^ parse result+    go+      :: Bool+      -- \^ in quoted region+      -> DList Char+      -- \^ accumulator+      -> String+      -- \^ string to be parsed+      -> [String]+    -- \^ parse result     go _ accum []       | [] <- accum' = []-      | otherwise    = [accum']-      where accum' = runDList accum--    go False  accum (c:cs)+      | otherwise = [accum']+      where+        accum' = runDList accum+    go False accum (c : cs)       | isSpace c = runDList accum : go False mempty cs-      | c == '"'  = go True accum cs--    go True   accum (c:cs)-      | c == '"'  = go False accum cs--    go quoted accum (c:cs)-                  = go quoted (accum `mappend` singleton c) cs-+      | c == '"' = go True accum cs+    go True accum (c : cs)+      | c == '"' = go False accum cs+    go quoted accum (c : cs) =+      go quoted (accum `mappend` singleton c) cs
− src/Distribution/License.hs 
@@ -1,252 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.License--- Description :  The License data type.--- Copyright   :  Isaac Jones 2003-2005---                Duncan Coutts 2008--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Package descriptions contain fields for specifying the name of a software--- license and the name of the file containing the text of that license. While--- package authors may choose any license they like, Cabal provides an--- enumeration of a small set of common free and open source software licenses.--- This is done so that Hackage can recognise licenses, so that tools can detect--- <https://en.wikipedia.org/wiki/License_compatibility licensing conflicts>,--- and to deter--- <https://en.wikipedia.org/wiki/License_proliferation license proliferation>.------ It is recommended that all package authors use the @license-file@ or--- @license-files@ fields in their package descriptions. Further information--- about these fields can be found in the--- <http://www.haskell.org/cabal/users-guide/developing-packages.html#package-descriptions Cabal users guide>.------ = Additional resources------ The following websites provide information about free and open source--- software licenses:------ * <http://www.opensource.org The Open Source Initiative (OSI)>------ * <https://www.fsf.org The Free Software Foundation (FSF)>------ = Disclaimer------ The descriptions of software licenses provided by this documentation are--- intended for informational purposes only and in no way constitute legal--- advice. Please read the text of the licenses and consult a lawyer for any--- advice regarding software licensing.--module Distribution.License (-    License(..),-    knownLicenses,-    licenseToSPDX,-    licenseFromSPDX,-  ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty-import Distribution.Version--import qualified Distribution.Compat.CharParsing as P-import qualified Data.Map.Strict                 as Map-import qualified Distribution.SPDX               as SPDX-import qualified Text.PrettyPrint                as Disp---- | Indicates the license under which a package's source code is released.--- Versions of the licenses not listed here will be rejected by Hackage and--- cause @cabal check@ to issue a warning.-data License =-    -- TODO: * remove BSD4--    -- | GNU General Public License,-    -- <https://www.gnu.org/licenses/old-licenses/gpl-2.0.html version 2> or-    -- <https://www.gnu.org/licenses/gpl.html version 3>.-    GPL (Maybe Version)--    -- | <https://www.gnu.org/licenses/agpl.html GNU Affero General Public License, version 3>.-  | AGPL (Maybe Version)--    -- | GNU Lesser General Public License,-    -- <https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html version 2.1> or-    -- <https://www.gnu.org/licenses/lgpl.html version 3>.-  | LGPL (Maybe Version)--    -- | <http://www.opensource.org/licenses/bsd-license 2-clause BSD license>.-  | BSD2--    -- | <http://www.opensource.org/licenses/bsd-3-clause 3-clause BSD license>.-  | BSD3--    -- | <http://directory.fsf.org/wiki/License:BSD_4Clause 4-clause BSD license>.-    -- This license has not been approved by the OSI and is incompatible with-    -- the GNU GPL. It is provided for historical reasons and should be avoided.-  | BSD4--    -- | <http://www.opensource.org/licenses/MIT MIT license>.-  | MIT--    -- | <http://www.isc.org/downloads/software-support-policy/isc-license/ ISC license>-  | ISC--    -- | <https://www.mozilla.org/MPL/ Mozilla Public License, version 2.0>.-  | MPL Version--    -- | <https://www.apache.org/licenses/ Apache License, version 2.0>.-  | Apache (Maybe Version)--    -- | The author of a package disclaims any copyright to its source code and-    -- dedicates it to the public domain. This is not a software license. Please-    -- note that it is not possible to dedicate works to the public domain in-    -- every jurisdiction, nor is a work that is in the public domain in one-    -- jurisdiction necessarily in the public domain elsewhere.-  | PublicDomain--    -- | Explicitly 'All Rights Reserved', eg for proprietary software. The-    -- package may not be legally modified or redistributed by anyone but the-    -- rightsholder.-  | AllRightsReserved--    -- | No license specified which legally defaults to 'All Rights Reserved'.-    -- The package may not be legally modified or redistributed by anyone but-    -- the rightsholder.-  | UnspecifiedLicense--    -- | Any other software license.-  | OtherLicense--    -- | Indicates an erroneous license name.-  | UnknownLicense String-  deriving (Generic, Read, Show, Eq, Typeable, Data)--instance Binary License-instance Structured License-instance NFData License where rnf = genericRnf---- | The list of all currently recognised licenses.-knownLicenses :: [License]-knownLicenses = [ GPL  unversioned, GPL  (version [2]),    GPL  (version [3])-                , LGPL unversioned, LGPL (version [2, 1]), LGPL (version [3])-                , AGPL unversioned,                        AGPL (version [3])-                , BSD2, BSD3, MIT, ISC-                , MPL (mkVersion [2, 0])-                , Apache unversioned, Apache (version [2, 0])-                , PublicDomain, AllRightsReserved, OtherLicense]-  where-    unversioned = Nothing-    version     = Just . mkVersion---- | Convert old 'License' to SPDX 'SPDX.License'.--- Non-SPDX licenses are converted to 'SPDX.LicenseRef'.------ @since 2.2.0.0-licenseToSPDX :: License -> SPDX.License-licenseToSPDX l = case l of-    GPL v | v == version [2]      -> spdx SPDX.GPL_2_0_only-    GPL v | v == version [3]      -> spdx SPDX.GPL_3_0_only-    LGPL v | v == version [2,1]   -> spdx SPDX.LGPL_2_1_only-    LGPL v | v == version [3]     -> spdx SPDX.LGPL_3_0_only-    AGPL v | v == version [3]     -> spdx SPDX.AGPL_3_0_only-    BSD2                          -> spdx SPDX.BSD_2_Clause-    BSD3                          -> spdx SPDX.BSD_3_Clause-    BSD4                          -> spdx SPDX.BSD_4_Clause-    MIT                           -> spdx SPDX.MIT-    ISC                           -> spdx SPDX.ISC-    MPL v | v == mkVersion [2,0]  -> spdx SPDX.MPL_2_0-    Apache v | v == version [2,0] -> spdx SPDX.Apache_2_0-    AllRightsReserved             -> SPDX.NONE-    UnspecifiedLicense            -> SPDX.NONE-    OtherLicense                  -> ref (SPDX.mkLicenseRef' Nothing "OtherLicense")-    PublicDomain                  -> ref (SPDX.mkLicenseRef' Nothing "PublicDomain")-    UnknownLicense str            -> ref (SPDX.mkLicenseRef' Nothing str)-    _                             -> ref (SPDX.mkLicenseRef' Nothing $ prettyShow l)-  where-    version = Just . mkVersion-    spdx    = SPDX.License . SPDX.simpleLicenseExpression-    ref  r  = SPDX.License $ SPDX.ELicense (SPDX.ELicenseRef r) Nothing---- | Convert 'SPDX.License' to 'License',------ This is lossy conversion. We try our best.------ >>> licenseFromSPDX . licenseToSPDX $ BSD3--- BSD3------ >>> licenseFromSPDX . licenseToSPDX $ GPL (Just (mkVersion [3]))--- GPL (Just (mkVersion [3]))------ >>> licenseFromSPDX . licenseToSPDX $ PublicDomain--- UnknownLicense "LicenseRefPublicDomain"------ >>> licenseFromSPDX $ SPDX.License $ SPDX.simpleLicenseExpression SPDX.EUPL_1_1--- UnknownLicense "EUPL-1.1"------ >>> licenseFromSPDX . licenseToSPDX $ AllRightsReserved--- AllRightsReserved------ >>> licenseFromSPDX <$> simpleParsec "BSD-3-Clause OR GPL-3.0-only"--- Just (UnknownLicense "BSD3ClauseORGPL30only")------ @since 2.2.0.0-licenseFromSPDX :: SPDX.License -> License-licenseFromSPDX SPDX.NONE = AllRightsReserved-licenseFromSPDX l =-    fromMaybe (mungle $ prettyShow l) $ Map.lookup l m-  where-    m :: Map.Map SPDX.License License-    m = Map.fromList $ filter (isSimple . fst ) $-        map (\x -> (licenseToSPDX x, x)) knownLicenses--    isSimple (SPDX.License (SPDX.ELicense (SPDX.ELicenseId _) Nothing)) = True-    isSimple _ = False--    mungle name = fromMaybe (UnknownLicense (mapMaybe mangle name)) (simpleParsec name)--    mangle c-        | isAlphaNum c = Just c-        | otherwise = Nothing--instance Pretty License where-  pretty (GPL  version)         = Disp.text "GPL"    <<>> dispOptVersion version-  pretty (LGPL version)         = Disp.text "LGPL"   <<>> dispOptVersion version-  pretty (AGPL version)         = Disp.text "AGPL"   <<>> dispOptVersion version-  pretty (MPL  version)         = Disp.text "MPL"    <<>> dispVersion    version-  pretty (Apache version)       = Disp.text "Apache" <<>> dispOptVersion version-  pretty (UnknownLicense other) = Disp.text other-  pretty other                  = Disp.text (show other)--instance Parsec License where-  parsec = do-    name    <- P.munch1 isAlphaNum-    version <- P.optional (P.char '-' *> parsec)-    return $! case (name, version :: Maybe Version) of-      ("GPL",               _      )  -> GPL  version-      ("LGPL",              _      )  -> LGPL version-      ("AGPL",              _      )  -> AGPL version-      ("BSD2",              Nothing)  -> BSD2-      ("BSD3",              Nothing)  -> BSD3-      ("BSD4",              Nothing)  -> BSD4-      ("ISC",               Nothing)  -> ISC-      ("MIT",               Nothing)  -> MIT-      ("MPL",         Just version')  -> MPL version'-      ("Apache",            _      )  -> Apache version-      ("PublicDomain",      Nothing)  -> PublicDomain-      ("AllRightsReserved", Nothing)  -> AllRightsReserved-      ("OtherLicense",      Nothing)  -> OtherLicense-      _                               -> UnknownLicense $ name ++-                                         maybe "" (('-':) . prettyShow) version--dispOptVersion :: Maybe Version -> Disp.Doc-dispOptVersion Nothing  = Disp.empty-dispOptVersion (Just v) = dispVersion v--dispVersion :: Version -> Disp.Doc-dispVersion v = Disp.char '-' <<>> pretty v
src/Distribution/Make.hs view
@@ -2,6 +2,11 @@ {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------++--                      copy :+--                              $(MAKE) install prefix=$(destdir)/$(prefix) \+--                                              bindir=$(destdir)/$(bindir) \+ -- | -- Module      :  Distribution.Make -- Copyright   :  Martin Sj&#xF6;gren 2004@@ -51,32 +56,26 @@ -- [UnregisterCmd] We assume there is an @unregister@ target. -- -- [HaddockCmd] We assume there is a @docs@ or @doc@ target.-----                      copy :---                              $(MAKE) install prefix=$(destdir)/$(prefix) \---                                              bindir=$(destdir)/$(bindir) \--module Distribution.Make (-        module Distribution.Package,-        License(..), Version,-        defaultMain, defaultMainArgs+module Distribution.Make+  ( module Distribution.Package+  , License (..)+  , Version+  , defaultMain+  , defaultMainArgs   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  -- local+import Distribution.License import Distribution.Package+import Distribution.Pretty+import Distribution.Simple.Command import Distribution.Simple.Program import Distribution.Simple.Setup-import Distribution.Simple.Command- import Distribution.Simple.Utils--import Distribution.License import Distribution.Version-import Distribution.Pretty  import System.Environment (getArgs, getProgName) @@ -87,20 +86,21 @@ defaultMainArgs = defaultMainHelper  defaultMainHelper :: [String] -> IO ()-defaultMainHelper args =-  case commandsRun (globalCommand commands) commands args of-    CommandHelp   help                 -> printHelp help-    CommandList   opts                 -> printOptionsList opts-    CommandErrors errs                 -> printErrors errs-    CommandReadyToGo (flags, commandParse)  ->+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 (globalVersion flags) -> printVersion           | fromFlag (globalNumericVersion flags) -> printNumericVersion-        CommandHelp     help           -> printHelp help-        CommandList     opts           -> printOptionsList opts-        CommandErrors   errs           -> printErrors errs-        CommandReadyToGo action        -> action-+        CommandHelp help -> printHelp help+        CommandList opts -> printOptionsList opts+        CommandErrors errs -> printErrors errs+        CommandReadyToGo action -> action   where     printHelp help = getProgName >>= putStr . help     printOptionsList = putStr . unlines@@ -108,75 +108,94 @@       putStr (intercalate "\n" errs)       exitWith (ExitFailure 1)     printNumericVersion = putStrLn $ prettyShow cabalVersion-    printVersion        = putStrLn $ "Cabal library version "-                                  ++ prettyShow cabalVersion-+    printVersion =+      putStrLn $+        "Cabal library version "+          ++ prettyShow cabalVersion     progs = defaultProgramDb     commands =-      [configureCommand progs `commandAddAction` configureAction-      ,buildCommand     progs `commandAddAction` buildAction-      ,installCommand         `commandAddAction` installAction-      ,copyCommand            `commandAddAction` copyAction-      ,haddockCommand         `commandAddAction` haddockAction-      ,cleanCommand           `commandAddAction` cleanAction-      ,sdistCommand           `commandAddAction` sdistAction-      ,registerCommand        `commandAddAction` registerAction-      ,unregisterCommand      `commandAddAction` unregisterAction+      [ configureCommand progs `commandAddAction` configureAction+      , buildCommand progs `commandAddAction` buildAction+      , installCommand `commandAddAction` installAction+      , copyCommand `commandAddAction` copyAction+      , haddockCommand `commandAddAction` haddockAction+      , cleanCommand `commandAddAction` cleanAction+      , sdistCommand `commandAddAction` sdistAction+      , registerCommand `commandAddAction` registerAction+      , unregisterCommand `commandAddAction` unregisterAction       ]  configureAction :: ConfigFlags -> [String] -> IO () configureAction flags args = do   noExtraFlags args-  let verbosity = fromFlag (configVerbosity flags)-  rawSystemExit verbosity "sh" $+  let verbosity = fromFlag $ configVerbosity flags+      mbWorkDir = flagToMaybe $ configWorkingDir flags+  rawSystemExit verbosity mbWorkDir "sh" $     "configure"-    : configureArgs backwardsCompatHack flags-  where backwardsCompatHack = True+      : configureArgs backwardsCompatHack flags+  where+    backwardsCompatHack = True  copyAction :: CopyFlags -> [String] -> IO () copyAction flags args = do   noExtraFlags args-  let destArgs = case fromFlag $ copyDest flags of-        NoCopyDest      -> ["install"]-        CopyTo path     -> ["copy", "destdir=" ++ path]-        CopyToDb _      -> error "CopyToDb not supported via Make"+  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 (fromFlag $ copyVerbosity flags) "make" destArgs+  rawSystemExit verbosity mbWorkDir "make" destArgs  installAction :: InstallFlags -> [String] -> IO () installAction flags args = do   noExtraFlags args-  rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"]-  rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"]+  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-  rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"]+  let verbosity = fromFlag $ haddockVerbosity flags+      mbWorkDir = flagToMaybe $ haddockWorkingDir flags+  rawSystemExit verbosity mbWorkDir "make" ["docs"]     `catchIO` \_ ->-    rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"]+      rawSystemExit verbosity mbWorkDir "make" ["doc"]  buildAction :: BuildFlags -> [String] -> IO () buildAction flags args = do   noExtraFlags args-  rawSystemExit (fromFlag $ buildVerbosity flags) "make" []+  let verbosity = fromFlag $ buildVerbosity flags+      mbWorkDir = flagToMaybe $ buildWorkingDir flags+  rawSystemExit verbosity mbWorkDir "make" []  cleanAction :: CleanFlags -> [String] -> IO () cleanAction flags args = do   noExtraFlags args-  rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"]+  let verbosity = fromFlag $ cleanVerbosity flags+      mbWorkDir = flagToMaybe $ cleanWorkingDir flags+  rawSystemExit verbosity mbWorkDir "make" ["clean"]  sdistAction :: SDistFlags -> [String] -> IO () sdistAction flags args = do   noExtraFlags args-  rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"]+  let verbosity = fromFlag $ sDistVerbosity flags+      mbWorkDir = flagToMaybe $ sDistWorkingDir flags+  rawSystemExit verbosity mbWorkDir "make" ["dist"]  registerAction :: RegisterFlags -> [String] -> IO ()-registerAction  flags args = do+registerAction flags args = do   noExtraFlags args-  rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"]+  let verbosity = fromFlag $ registerVerbosity flags+      mbWorkDir = flagToMaybe $ registerWorkingDir flags+  rawSystemExit verbosity mbWorkDir "make" ["register"]  unregisterAction :: RegisterFlags -> [String] -> IO () unregisterAction flags args = do   noExtraFlags args-  rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"]+  let verbosity = fromFlag $ registerVerbosity flags+      mbWorkDir = flagToMaybe $ registerWorkingDir flags+  rawSystemExit verbosity mbWorkDir "make" ["unregister"]
− src/Distribution/ModuleName.hs 
@@ -1,131 +0,0 @@-{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE ScopedTypeVariables #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.ModuleName--- Copyright   :  Duncan Coutts 2008--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Data type for Haskell module names.--module Distribution.ModuleName (-        ModuleName,-        fromString,-        fromComponents,-        components,-        toFilePath,-        main,-        -- * Internal-        validModuleComponent,-  ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty-import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText)-import System.FilePath              (pathSeparator)--import qualified Distribution.Compat.CharParsing as P-import qualified Distribution.Compat.DList       as DList-import qualified Text.PrettyPrint                as Disp---- | A valid Haskell module name.----newtype ModuleName = ModuleName ShortText-  deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)--unModuleName :: ModuleName -> String-unModuleName (ModuleName s) = fromShortText s--instance Binary ModuleName-instance Structured ModuleName--instance NFData ModuleName where-    rnf (ModuleName ms) = rnf ms--instance Pretty ModuleName where-  pretty = Disp.text . unModuleName--instance Parsec ModuleName where-    parsec = parsecModuleName--parsecModuleName :: forall m. CabalParsing m => m ModuleName-parsecModuleName = state0 DList.empty where-    upper :: m Char-    !upper = P.satisfy isUpper--    ch :: m Char-    !ch = P.satisfy (\c -> validModuleChar c || c == '.')--    alt :: m ModuleName -> m ModuleName -> m ModuleName-    !alt = (<|>)--    state0 :: DList.DList Char -> m ModuleName-    state0 acc = do-        c <- upper-        state1 (DList.snoc acc c)--    state1 :: DList.DList Char -> m ModuleName-    state1 acc = state1' acc `alt` return (fromString (DList.toList acc))--    state1' :: DList.DList Char -> m ModuleName-    state1' acc = do-        c <- ch-        case c of-            '.' -> state0 (DList.snoc acc c)-            _   -> state1 (DList.snoc acc c)--validModuleChar :: Char -> Bool-validModuleChar c = isAlphaNum c || c == '_' || c == '\''--validModuleComponent :: String -> Bool-validModuleComponent []     = False-validModuleComponent (c:cs) = isUpper c && all validModuleChar cs---- | Construct a 'ModuleName' from a valid module name 'String'.------ This is just a convenience function intended for valid module strings. It is--- an error if it is used with a string that is not a valid module name. If you--- are parsing user input then use 'Distribution.Text.simpleParse' instead.----instance IsString ModuleName where-    fromString = ModuleName . toShortText---- | Construct a 'ModuleName' from valid module components, i.e. parts--- separated by dots.-fromComponents :: [String] -> ModuleName-fromComponents comps = fromString (intercalate "." comps)-{-# DEPRECATED fromComponents "Exists for cabal-install only" #-}---- | The module name @Main@.----main :: ModuleName-main = ModuleName (fromString "Main")---- | The individual components of a hierarchical module name. For example------ > components (fromString "A.B.C") = ["A", "B", "C"]----components :: ModuleName -> [String]-components mn = split (unModuleName mn)-  where-    split cs = case break (=='.') cs of-      (chunk,[])     -> chunk : []-      (chunk,_:rest) -> chunk : split rest---- | Convert a module name to a file path, but without any file extension.--- For example:------ > toFilePath (fromString "A.B.C") = "A/B/C"----toFilePath :: ModuleName -> FilePath-toFilePath = map f . unModuleName where-    f '.' = pathSeparator-    f c   = c
− src/Distribution/Package.hs 
@@ -1,96 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Package--- Copyright   :  Isaac Jones 2003-2004--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Defines a package identifier along with a parser and pretty printer for it.--- 'PackageIdentifier's consist of a name and an exact version. It also defines--- a 'Dependency' data type. A dependency is a package name and a version--- range, like @\"foo >= 1.2 && < 2\"@.--module Distribution.Package-  ( module Distribution.Types.AbiHash-  , module Distribution.Types.ComponentId-  , module Distribution.Types.PackageId-  , module Distribution.Types.UnitId-  , module Distribution.Types.Module-  , module Distribution.Types.PackageName-  , module Distribution.Types.PkgconfigName-  , module Distribution.Types.Dependency-  , Package(..), packageName, packageVersion-  , HasMungedPackageId(..), mungedName', mungedVersion'-  , HasUnitId(..)-  , PackageInstalled(..)-  ) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Version-         ( Version )--import Distribution.Types.AbiHash-import Distribution.Types.ComponentId-import Distribution.Types.Dependency-import Distribution.Types.MungedPackageId-import Distribution.Types.PackageId-import Distribution.Types.UnitId-import Distribution.Types.Module-import Distribution.Types.MungedPackageName-import Distribution.Types.PackageName-import Distribution.Types.PkgconfigName---- | Class of things that have a 'PackageIdentifier'------ Types in this class are all notions of a package. This allows us to have--- different types for the different phases that packages go though, from--- simple name\/id, package description, configured or installed packages.------ Not all kinds of packages can be uniquely identified by a--- 'PackageIdentifier'. In particular, installed packages cannot, there may be--- many installed instances of the same source package.----class Package pkg where-  packageId  :: pkg -> PackageIdentifier--mungedName'    :: HasMungedPackageId pkg => pkg -> MungedPackageName-mungedName'     = mungedName    . mungedId--mungedVersion' :: HasMungedPackageId munged => munged -> Version-mungedVersion'  = mungedVersion . mungedId--class HasMungedPackageId pkg where-  mungedId :: pkg -> MungedPackageId--instance Package PackageIdentifier where-  packageId = id--packageName    :: Package pkg => pkg -> PackageName-packageName     = pkgName    . packageId--packageVersion :: Package pkg => pkg -> Version-packageVersion  = pkgVersion . packageId--instance HasMungedPackageId MungedPackageId where-  mungedId = id---- | Packages that have an installed unit ID-class Package pkg => HasUnitId pkg where-  installedUnitId :: pkg -> UnitId---- | Class of installed packages.------ The primary data type which is an instance of this package is--- 'InstalledPackageInfo', but when we are doing install plans in Cabal install--- we may have other, installed package-like things which contain more metadata.--- Installed packages have exact dependencies 'installedDepends'.-class (HasUnitId pkg) => PackageInstalled pkg where-  installedDepends :: pkg -> [UnitId]
− src/Distribution/PackageDescription.hs 
@@ -1,113 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription--- Copyright   :  Isaac Jones 2003-2005--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Backwards compatibility reexport of most things you need to know--- about @.cabal@ files.--module Distribution.PackageDescription (-    -- * PD and GPD-    module Distribution.Types.PackageDescription,-    module Distribution.Types.GenericPackageDescription,-    -- * Components-    module Distribution.Types.ComponentName,-    -- ** Library-    module Distribution.Types.Library,-    module Distribution.Types.LibraryName,-    module Distribution.Types.LibraryVisibility,-    -- ** Executable-    module Distribution.Types.Executable,-    module Distribution.Types.ExecutableScope,-    -- ** TestSuite-    module Distribution.Types.TestSuite,-    module Distribution.Types.TestType,-    module Distribution.Types.TestSuiteInterface,-    -- ** Benchmark-    module Distribution.Types.Benchmark,-    module Distribution.Types.BenchmarkType,-    module Distribution.Types.BenchmarkInterface,-    -- ** Foreign library-    module Distribution.Types.ForeignLib,-    module Distribution.Types.ForeignLibType,-    module Distribution.Types.ForeignLibOption,-    -- * BuildInfo-    module Distribution.Types.BuildType,-    module Distribution.Types.BuildInfo,-    module Distribution.Types.HookedBuildInfo,-    module Distribution.Types.SetupBuildInfo,-    -- * Flags-    module Distribution.Types.Flag,-    -- * Identifiers-    module Distribution.Types.PackageId,-    module Distribution.Types.PackageName,-    module Distribution.Types.UnqualComponentName,-    -- * Pkgconfig-    module Distribution.Types.PkgconfigName,-    module Distribution.Types.PkgconfigVersion,-    module Distribution.Types.PkgconfigVersionRange,-    -- * Dependencies-    module Distribution.Types.Dependency,-    module Distribution.Types.ExeDependency,-    module Distribution.Types.LegacyExeDependency,-    module Distribution.Types.PkgconfigDependency,-    -- * Condition trees-    module Distribution.Types.CondTree,-    module Distribution.Types.Condition,-    module Distribution.Types.ConfVar,-    -- * Mixin-   module Distribution.Types.IncludeRenaming,-   module Distribution.Types.Mixin,-   module Distribution.Types.ModuleReexport,-   module Distribution.Types.ModuleRenaming,-    -- * Source repository-    module Distribution.Types.SourceRepo,-  ) where--import Prelude ()---import Distribution.Compat.Prelude--import Distribution.Types.Benchmark-import Distribution.Types.BenchmarkInterface-import Distribution.Types.BenchmarkType-import Distribution.Types.BuildInfo-import Distribution.Types.BuildType-import Distribution.Types.ComponentName-import Distribution.Types.Condition-import Distribution.Types.CondTree-import Distribution.Types.ConfVar-import Distribution.Types.Dependency-import Distribution.Types.Executable-import Distribution.Types.ExecutableScope-import Distribution.Types.ExeDependency-import Distribution.Types.Flag-import Distribution.Types.ForeignLib-import Distribution.Types.ForeignLibOption-import Distribution.Types.ForeignLibType-import Distribution.Types.GenericPackageDescription-import Distribution.Types.HookedBuildInfo-import Distribution.Types.IncludeRenaming-import Distribution.Types.LegacyExeDependency-import Distribution.Types.Library-import Distribution.Types.LibraryName-import Distribution.Types.LibraryVisibility-import Distribution.Types.Mixin-import Distribution.Types.ModuleReexport-import Distribution.Types.ModuleRenaming-import Distribution.Types.PackageDescription-import Distribution.Types.PackageId-import Distribution.Types.PackageName-import Distribution.Types.PkgconfigDependency-import Distribution.Types.PkgconfigName-import Distribution.Types.PkgconfigVersion-import Distribution.Types.PkgconfigVersionRange-import Distribution.Types.SetupBuildInfo-import Distribution.Types.SourceRepo-import Distribution.Types.TestSuite-import Distribution.Types.TestSuiteInterface-import Distribution.Types.TestType-import Distribution.Types.UnqualComponentName
src/Distribution/PackageDescription/Check.hs view
@@ -1,2392 +1,1111 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription.Check--- Copyright   :  Lennart Kolmodin 2008--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This has code for checking for various problems in packages. There is one--- set of checks that just looks at a 'PackageDescription' in isolation and--- another set of checks that also looks at files in the package. Some of the--- checks are basic sanity checks, others are portability standards that we'd--- like to encourage. There is a 'PackageCheck' type that distinguishes the--- different kinds of checks so we can see which ones are appropriate to report--- in different situations. This code gets used when configuring a package when--- we consider only basic problems. The higher standard is used when--- preparing a source tarball and by Hackage when uploading new packages. The--- reason for this is that we want to hold packages that are expected to be--- distributed to a higher standard than packages that are only ever expected--- to be used on the author's own environment.--module Distribution.PackageDescription.Check (-        -- * Package Checking-        PackageCheck(..),-        checkPackage,-        checkConfiguredPackage,--        -- ** Checking package contents-        checkPackageFiles,-        checkPackageContent,-        CheckPackageContentOps(..),-        checkPackageFileNames,-  ) where--import Distribution.Compat.Prelude-import Prelude ()--import Data.List                                     (group)-import Distribution.CabalSpecVersion-import Distribution.Compat.Lens-import Distribution.Compiler-import Distribution.License-import Distribution.Package-import Distribution.PackageDescription-import Distribution.PackageDescription.Configuration-import Distribution.Pretty                           (prettyShow)-import Distribution.Simple.BuildPaths                (autogenPathsModuleName)-import Distribution.Simple.BuildToolDepends-import Distribution.Simple.CCompiler-import Distribution.Simple.Glob-import Distribution.Simple.Utils                     hiding (findPackageDesc, notice)-import Distribution.System-import Distribution.Types.ComponentRequestedSpec-import Distribution.Utils.Generic                    (isAscii)-import Distribution.Verbosity-import Distribution.Version-import Distribution.Utils.Path-import Language.Haskell.Extension-import System.FilePath-       (splitDirectories, splitExtension, splitPath, takeExtension, takeFileName, (<.>), (</>))--import qualified Data.ByteString.Lazy      as BS-import qualified Data.Map                  as Map-import qualified Distribution.Compat.DList as DList-import qualified Distribution.SPDX         as SPDX-import qualified System.Directory          as System--import qualified System.Directory        (getDirectoryContents)-import qualified System.FilePath.Windows as FilePath.Windows (isValid)--import qualified Data.Set as Set-import qualified Distribution.Utils.ShortText as ShortText--import qualified Distribution.Types.BuildInfo.Lens                 as L-import qualified Distribution.Types.GenericPackageDescription.Lens as L-import qualified Distribution.Types.PackageDescription.Lens        as L---- $setup--- >>> import Control.Arrow ((&&&))---- | Results of some kind of failed package check.------ There are a range of severities, from merely dubious to totally insane.--- All of them come with a human readable explanation. In future we may augment--- them with more machine readable explanations, for example to help an IDE--- suggest automatic corrections.----data PackageCheck =--       -- | This package description is no good. There's no way it's going to-       -- build sensibly. This should give an error at configure time.-       PackageBuildImpossible { explanation :: String }--       -- | A problem that is likely to affect building the package, or an-       -- issue that we'd like every package author to be aware of, even if-       -- the package is never distributed.-     | PackageBuildWarning { explanation :: String }--       -- | An issue that might not be a problem for the package author but-       -- might be annoying or detrimental when the package is distributed to-       -- users. We should encourage distributed packages to be free from these-       -- issues, but occasionally there are justifiable reasons so we cannot-       -- ban them entirely.-     | PackageDistSuspicious { explanation :: String }--       -- | Like PackageDistSuspicious but will only display warnings-       -- rather than causing abnormal exit when you run 'cabal check'.-     | PackageDistSuspiciousWarn { explanation :: String }--       -- | An issue that is OK in the author's environment but is almost-       -- certain to be a portability problem for other environments. We can-       -- quite legitimately refuse to publicly distribute packages with these-       -- problems.-     | PackageDistInexcusable { explanation :: String }-  deriving (Eq, Ord)--instance Show PackageCheck where-    show notice = explanation notice--check :: Bool -> PackageCheck -> Maybe PackageCheck-check False _  = Nothing-check True  pc = Just pc--checkSpecVersion :: PackageDescription -> CabalSpecVersion -> Bool -> PackageCheck-                 -> Maybe PackageCheck-checkSpecVersion pkg specver cond pc-  | specVersion pkg >= specver  = Nothing-  | otherwise                   = check cond pc---- --------------------------------------------------------------- * Standard checks--- ---------------------------------------------------------------- | Check for common mistakes and problems in package descriptions.------ This is the standard collection of checks covering all aspects except--- for checks that require looking at files within the package. For those--- see 'checkPackageFiles'.------ It requires the 'GenericPackageDescription' and optionally a particular--- configuration of that package. If you pass 'Nothing' then we just check--- a version of the generic description using 'flattenPackageDescription'.----checkPackage :: GenericPackageDescription-             -> Maybe PackageDescription-             -> [PackageCheck]-checkPackage gpkg mpkg =-     checkConfiguredPackage pkg-  ++ checkConditionals gpkg-  ++ checkPackageVersions gpkg-  ++ checkDevelopmentOnlyFlags gpkg-  ++ checkFlagNames gpkg-  ++ checkUnusedFlags gpkg-  ++ checkUnicodeXFields gpkg-  ++ checkPathsModuleExtensions pkg-  where-    pkg = fromMaybe (flattenPackageDescription gpkg) mpkg----TODO: make this variant go away---      we should always know the GenericPackageDescription-checkConfiguredPackage :: PackageDescription -> [PackageCheck]-checkConfiguredPackage pkg =-    checkSanity pkg- ++ checkFields pkg- ++ checkLicense pkg- ++ checkSourceRepos pkg- ++ checkAllGhcOptions pkg- ++ checkCCOptions pkg- ++ checkCxxOptions pkg- ++ checkCPPOptions pkg- ++ checkPaths pkg- ++ checkCabalVersion pkg----- --------------------------------------------------------------- * Basic sanity checks--- ---------------------------------------------------------------- | Check that this package description is sane.----checkSanity :: PackageDescription -> [PackageCheck]-checkSanity pkg =-  catMaybes [--    check (null . unPackageName . packageName $ pkg) $-      PackageBuildImpossible "No 'name' field."--  , check (nullVersion == packageVersion pkg) $-      PackageBuildImpossible "No 'version' field."--  , check (all ($ pkg) [ null . executables-                       , null . testSuites-                       , null . benchmarks-                       , null . allLibraries-                       , null . foreignLibs ]) $-      PackageBuildImpossible-        "No executables, libraries, tests, or benchmarks found. Nothing to do."--  , check (any (== LMainLibName) (map libName $ subLibraries pkg)) $-      PackageBuildImpossible $ "Found one or more unnamed internal libraries. "-        ++ "Only the non-internal library can have the same name as the package."--  , check (not (null duplicateNames)) $-      PackageBuildImpossible $ "Duplicate sections: "-        ++ commaSep (map unUnqualComponentName duplicateNames)-        ++ ". The name of every library, executable, test suite,"-        ++ " and benchmark section in"-        ++ " the package must be unique."--  -- NB: but it's OK for executables to have the same name!-  -- TODO shouldn't need to compare on the string level-  , check (any (== prettyShow (packageName pkg)) (prettyShow <$> subLibNames)) $-      PackageBuildImpossible $ "Illegal internal library name "-        ++ prettyShow (packageName pkg)-        ++ ". Internal libraries cannot have the same name as the package."-        ++ " Maybe you wanted a non-internal library?"-        ++ " If so, rewrite the section stanza"-        ++ " from 'library: '" ++ prettyShow (packageName pkg) ++ "' to 'library'."-  ]-  --TODO: check for name clashes case insensitively: windows file systems cannot-  --cope.--  ++ concatMap (checkLibrary    pkg) (allLibraries pkg)-  ++ concatMap (checkExecutable pkg) (executables pkg)-  ++ concatMap (checkTestSuite  pkg) (testSuites pkg)-  ++ concatMap (checkBenchmark  pkg) (benchmarks pkg)--  where-    -- The public 'library' gets special dispensation, because it-    -- is common practice to export a library and name the executable-    -- the same as the package.-    subLibNames = mapMaybe (libraryNameString . libName) $ subLibraries pkg-    exeNames = map exeName $ executables pkg-    testNames = map testName $ testSuites pkg-    bmNames = map benchmarkName $ benchmarks pkg-    duplicateNames = dups $ subLibNames ++ exeNames ++ testNames ++ bmNames--checkLibrary :: PackageDescription -> Library -> [PackageCheck]-checkLibrary pkg lib =-  catMaybes [--    check (not (null moduleDuplicates)) $-       PackageBuildImpossible $-            "Duplicate modules in library: "-         ++ commaSep (map prettyShow moduleDuplicates)--  -- TODO: This check is bogus if a required-signature was passed through-  , check (null (explicitLibModules lib) && null (reexportedModules lib)) $-      PackageDistSuspiciousWarn $-           showLibraryName (libName lib) ++ " does not expose any modules"--    -- check use of signatures sections-  , checkVersion CabalSpecV2_0 (not (null (signatures lib))) $-      PackageDistInexcusable $-           "To use the 'signatures' field the package needs to specify "-        ++ "at least 'cabal-version: 2.0'."--    -- check that all autogen-modules appear on other-modules or exposed-modules-  , check-      (not $ and $ map (flip elem (explicitLibModules lib)) (libModulesAutogen lib)) $-      PackageBuildImpossible $-           "An 'autogen-module' is neither on 'exposed-modules' or "-        ++ "'other-modules'."--    -- check that all autogen-includes appear on includes or install-includes-  , check-      (not $ and $ map (flip elem (allExplicitIncludes lib)) (view L.autogenIncludes lib)) $-      PackageBuildImpossible $-           "An include in 'autogen-includes' is neither in 'includes' or "-        ++ "'install-includes'."-  ]--  where-    checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck-    checkVersion ver cond pc-      | specVersion pkg >= ver = Nothing-      | otherwise              = check cond pc--    -- TODO: not sure if this check is always right in Backpack-    moduleDuplicates = dups (explicitLibModules lib ++-                             map moduleReexportName (reexportedModules lib))--allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath]-allExplicitIncludes x = view L.includes x ++ view L.installIncludes x--checkExecutable :: PackageDescription -> Executable -> [PackageCheck]-checkExecutable pkg exe =-  catMaybes [--    check (null (modulePath exe)) $-      PackageBuildImpossible $-        "No 'main-is' field found for executable " ++ prettyShow (exeName exe)--  , check (not (null (modulePath exe))-       && (not $ fileExtensionSupportedLanguage $ modulePath exe)) $-      PackageBuildImpossible $-           "The 'main-is' field must specify a '.hs' or '.lhs' file "-        ++ "(even if it is generated by a preprocessor), "-        ++ "or it may specify a C/C++/obj-C source file."--  , checkSpecVersion pkg CabalSpecV1_18-          (fileExtensionSupportedLanguage (modulePath exe)-        && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $-      PackageDistInexcusable $-           "The package uses a C/C++/obj-C source file for the 'main-is' field. "-        ++ "To use this feature you must specify 'cabal-version: >= 1.18'."--  , check (not (null moduleDuplicates)) $-       PackageBuildImpossible $-            "Duplicate modules in executable '" ++ prettyShow (exeName exe) ++ "': "-         ++ commaSep (map prettyShow moduleDuplicates)--    -- check that all autogen-modules appear on other-modules-  , check-      (not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) $-      PackageBuildImpossible $-           "On executable '" ++ prettyShow (exeName exe) ++ "' an 'autogen-module' is not "-        ++ "on 'other-modules'"--    -- check that all autogen-includes appear on includes-  , check-      (not $ and $ map (flip elem (view L.includes exe)) (view L.autogenIncludes exe)) $-      PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'."-  ]-  where-    moduleDuplicates = dups (exeModules exe)--checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck]-checkTestSuite pkg test =-  catMaybes [--    case testInterface test of-      TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $-        PackageBuildWarning $-             quote (prettyShow tt) ++ " is not a known type of test suite. "-          ++ "The known test suite types are: "-          ++ commaSep (map prettyShow knownTestTypes)--      TestSuiteUnsupported tt -> Just $-        PackageBuildWarning $-             quote (prettyShow tt) ++ " is not a supported test suite version. "-          ++ "The known test suite types are: "-          ++ commaSep (map prettyShow knownTestTypes)-      _ -> Nothing--  , check (not $ null moduleDuplicates) $-      PackageBuildImpossible $-           "Duplicate modules in test suite '" ++ prettyShow (testName test) ++ "': "-        ++ commaSep (map prettyShow moduleDuplicates)--  , check mainIsWrongExt $-      PackageBuildImpossible $-           "The 'main-is' field must specify a '.hs' or '.lhs' file "-        ++ "(even if it is generated by a preprocessor), "-        ++ "or it may specify a C/C++/obj-C source file."--  , checkSpecVersion pkg CabalSpecV1_18 (mainIsNotHsExt && not mainIsWrongExt) $-      PackageDistInexcusable $-           "The package uses a C/C++/obj-C source file for the 'main-is' field. "-        ++ "To use this feature you must specify 'cabal-version: >= 1.18'."--    -- check that all autogen-modules appear on other-modules-  , check-      (not $ and $ map (flip elem (testModules test)) (testModulesAutogen test)) $-      PackageBuildImpossible $-           "On test suite '" ++ prettyShow (testName test) ++ "' an 'autogen-module' is not "-        ++ "on 'other-modules'"--    -- check that all autogen-includes appear on includes-  , check-      (not $ and $ map (flip elem (view L.includes test)) (view L.autogenIncludes test)) $-      PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'."-  ]-  where-    moduleDuplicates = dups $ testModules test--    mainIsWrongExt = case testInterface test of-      TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f-      _                   -> False--    mainIsNotHsExt = case testInterface test of-      TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]-      _                   -> False--checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck]-checkBenchmark _pkg bm =-  catMaybes [--    case benchmarkInterface bm of-      BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $-        PackageBuildWarning $-             quote (prettyShow tt) ++ " is not a known type of benchmark. "-          ++ "The known benchmark types are: "-          ++ commaSep (map prettyShow knownBenchmarkTypes)--      BenchmarkUnsupported tt -> Just $-        PackageBuildWarning $-             quote (prettyShow tt) ++ " is not a supported benchmark version. "-          ++ "The known benchmark types are: "-          ++ commaSep (map prettyShow knownBenchmarkTypes)-      _ -> Nothing--  , check (not $ null moduleDuplicates) $-      PackageBuildImpossible $-           "Duplicate modules in benchmark '" ++ prettyShow (benchmarkName bm) ++ "': "-        ++ commaSep (map prettyShow moduleDuplicates)--  , check mainIsWrongExt $-      PackageBuildImpossible $-           "The 'main-is' field must specify a '.hs' or '.lhs' file "-        ++ "(even if it is generated by a preprocessor)."--    -- check that all autogen-modules appear on other-modules-  , check-      (not $ and $ map (flip elem (benchmarkModules bm)) (benchmarkModulesAutogen bm)) $-      PackageBuildImpossible $-             "On benchmark '" ++ prettyShow (benchmarkName bm) ++ "' an 'autogen-module' is "-          ++ "not on 'other-modules'"--    -- check that all autogen-includes appear on includes-  , check-      (not $ and $ map (flip elem (view L.includes bm)) (view L.autogenIncludes bm)) $-      PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'."-  ]-  where-    moduleDuplicates = dups $ benchmarkModules bm--    mainIsWrongExt = case benchmarkInterface bm of-      BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]-      _                   -> False---- --------------------------------------------------------------- * Additional pure checks--- --------------------------------------------------------------checkFields :: PackageDescription -> [PackageCheck]-checkFields pkg =-  catMaybes [--    check (not . FilePath.Windows.isValid . prettyShow . packageName $ pkg) $-      PackageDistInexcusable $-           "Unfortunately, the package name '" ++ prettyShow (packageName pkg)-        ++ "' is one of the reserved system file names on Windows. Many tools "-        ++ "need to convert package names to file names so using this name "-        ++ "would cause problems."--  , check ((isPrefixOf "z-") . prettyShow . packageName $ pkg) $-      PackageDistInexcusable $-           "Package names with the prefix 'z-' are reserved by Cabal and "-        ++ "cannot be used."--  , check (isNothing (buildTypeRaw pkg) && specVersion pkg < CabalSpecV2_2) $-      PackageBuildWarning $-           "No 'build-type' specified. If you do not need a custom Setup.hs or "-        ++ "./configure script then use 'build-type: Simple'."--  , check (isJust (setupBuildInfo pkg) && buildType pkg /= Custom) $-      PackageBuildWarning $-           "Ignoring the 'custom-setup' section because the 'build-type' is "-        ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a "-        ++ "custom Setup.hs script."--  , check (not (null unknownCompilers)) $-      PackageBuildWarning $-        "Unknown compiler " ++ commaSep (map quote unknownCompilers)-                            ++ " in 'tested-with' field."--  , check (not (null unknownLanguages)) $-      PackageBuildWarning $-        "Unknown languages: " ++ commaSep unknownLanguages--  , check (not (null unknownExtensions)) $-      PackageBuildWarning $-        "Unknown extensions: " ++ commaSep unknownExtensions--  , check (not (null languagesUsedAsExtensions)) $-      PackageBuildWarning $-           "Languages listed as extensions: "-        ++ commaSep languagesUsedAsExtensions-        ++ ". Languages must be specified in either the 'default-language' "-        ++ " or the 'other-languages' field."--  , check (not (null ourDeprecatedExtensions)) $-      PackageDistSuspicious $-           "Deprecated extensions: "-        ++ commaSep (map (quote . prettyShow . fst) ourDeprecatedExtensions)-        ++ ". " ++ unwords-             [ "Instead of '" ++ prettyShow ext-            ++ "' use '" ++ prettyShow replacement ++ "'."-             | (ext, Just replacement) <- ourDeprecatedExtensions ]--  , check (ShortText.null (category pkg)) $-      PackageDistSuspicious "No 'category' field."--  , check (ShortText.null (maintainer pkg)) $-      PackageDistSuspicious "No 'maintainer' field."--  , check (ShortText.null (synopsis pkg) && ShortText.null (description pkg)) $-      PackageDistInexcusable "No 'synopsis' or 'description' field."--  , check (ShortText.null (description pkg) && not (ShortText.null (synopsis pkg))) $-      PackageDistSuspicious "No 'description' field."--  , check (ShortText.null (synopsis pkg) && not (ShortText.null (description pkg))) $-      PackageDistSuspicious "No 'synopsis' field."--    --TODO: recommend the bug reports URL, author and homepage fields-    --TODO: recommend not using the stability field-    --TODO: recommend specifying a source repo--  , check (ShortText.length (synopsis pkg) >= 80) $-      PackageDistSuspicious-        "The 'synopsis' field is rather long (max 80 chars is recommended)."--    -- See also https://github.com/haskell/cabal/pull/3479-  , check (not (ShortText.null (description pkg))-           && ShortText.length (description pkg) <= ShortText.length (synopsis pkg)) $-      PackageDistSuspicious $-           "The 'description' field should be longer than the 'synopsis' "-        ++ "field. "-        ++ "It's useful to provide an informative 'description' to allow "-        ++ "Haskell programmers who have never heard about your package to "-        ++ "understand the purpose of your package. "-        ++ "The 'description' field content is typically shown by tooling "-        ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which "-        ++ "serves as a headline. "-        ++ "Please refer to <https://www.haskell.org/"-        ++ "cabal/users-guide/developing-packages.html#package-properties>"-        ++ " for more details."--    -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12"-  , check (not (null testedWithImpossibleRanges)) $-      PackageDistInexcusable $-           "Invalid 'tested-with' version range: "-        ++ commaSep (map prettyShow testedWithImpossibleRanges)-        ++ ". To indicate that you have tested a package with multiple "-        ++ "different versions of the same compiler use multiple entries, "-        ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not "-        ++ "'tested-with: GHC==6.10.4 && ==6.12.3'."--  -- for more details on why the following was commented out,-  -- check https://github.com/haskell/cabal/pull/7470#issuecomment-875878507-  -- , check (not (null depInternalLibraryWithExtraVersion)) $-  --     PackageBuildWarning $-  --          "The package has an extraneous version range for a dependency on an "-  --       ++ "internal library: "-  --       ++ commaSep (map prettyShow depInternalLibraryWithExtraVersion)-  --       ++ ". This version range includes the current package but isn't needed "-  --       ++ "as the current package's library will always be used."--  , check (not (null depInternalLibraryWithImpossibleVersion)) $-      PackageBuildImpossible $-           "The package has an impossible version range for a dependency on an "-        ++ "internal library: "-        ++ commaSep (map prettyShow depInternalLibraryWithImpossibleVersion)-        ++ ". This version range does not include the current package, and must "-        ++ "be removed as the current package's library will always be used."--  -- , check (not (null depInternalExecutableWithExtraVersion)) $-  --     PackageBuildWarning $-  --          "The package has an extraneous version range for a dependency on an "-  --       ++ "internal executable: "-  --       ++ commaSep (map prettyShow depInternalExecutableWithExtraVersion)-  --       ++ ". This version range includes the current package but isn't needed "-  --       ++ "as the current package's executable will always be used."--  , check (not (null depInternalExecutableWithImpossibleVersion)) $-      PackageBuildImpossible $-           "The package has an impossible version range for a dependency on an "-        ++ "internal executable: "-        ++ commaSep (map prettyShow depInternalExecutableWithImpossibleVersion)-        ++ ". This version range does not include the current package, and must "-        ++ "be removed as the current package's executable will always be used."--  , check (not (null depMissingInternalExecutable)) $-      PackageBuildImpossible $-           "The package depends on a missing internal executable: "-        ++ commaSep (map prettyShow depInternalExecutableWithImpossibleVersion)-  ]-  where-    unknownCompilers  = [ name | (OtherCompiler name, _) <- testedWith pkg ]-    unknownLanguages  = [ name | bi <- allBuildInfo pkg-                               , UnknownLanguage name <- allLanguages bi ]-    unknownExtensions = [ name | bi <- allBuildInfo pkg-                               , UnknownExtension name <- allExtensions bi-                               , name `notElem` map prettyShow knownLanguages ]-    ourDeprecatedExtensions = nub $ catMaybes-      [ find ((==ext) . fst) deprecatedExtensions-      | bi <- allBuildInfo pkg-      , ext <- allExtensions bi ]-    languagesUsedAsExtensions =-      [ name | bi <- allBuildInfo pkg-             , UnknownExtension name <- allExtensions bi-             , name `elem` map prettyShow knownLanguages ]--    testedWithImpossibleRanges =-      [ Dependency (mkPackageName (prettyShow compiler)) vr mainLibSet-      | (compiler, vr) <- testedWith pkg-      , isNoVersion vr ]--    internalLibraries =-        map (maybe (packageName pkg) (unqualComponentNameToPackageName) . libraryNameString . libName)-            (allLibraries pkg)--    internalExecutables = map exeName $ executables pkg--    internalLibDeps =-      [ dep-      | bi <- allBuildInfo pkg-      , dep@(Dependency name _ _) <- targetBuildDepends bi-      , name `elem` internalLibraries-      ]--    internalExeDeps =-      [ dep-      | bi <- allBuildInfo pkg-      , dep <- getAllToolDependencies pkg bi-      , isInternal pkg dep-      ]--    -- depInternalLibraryWithExtraVersion =-    --   [ dep-    --   | dep@(Dependency _ versionRange _) <- internalLibDeps-    --   , not $ isAnyVersion versionRange-    --   , packageVersion pkg `withinRange` versionRange-    --   ]--    depInternalLibraryWithImpossibleVersion =-      [ dep-      | dep@(Dependency _ versionRange _) <- internalLibDeps-      , not $ packageVersion pkg `withinRange` versionRange-      ]--    -- depInternalExecutableWithExtraVersion =-    --   [ dep-    --   | dep@(ExeDependency _ _ versionRange) <- internalExeDeps-    --   , not $ isAnyVersion versionRange-    --   , packageVersion pkg `withinRange` versionRange-    --   ]--    depInternalExecutableWithImpossibleVersion =-      [ dep-      | dep@(ExeDependency _ _ versionRange) <- internalExeDeps-      , not $ packageVersion pkg `withinRange` versionRange-      ]--    depMissingInternalExecutable =-      [ dep-      | dep@(ExeDependency _ eName _) <- internalExeDeps-      , not $ eName `elem` internalExecutables-      ]---checkLicense :: PackageDescription -> [PackageCheck]-checkLicense pkg = case licenseRaw pkg of-    Right l -> checkOldLicense pkg l-    Left  l -> checkNewLicense pkg l--checkNewLicense :: PackageDescription -> SPDX.License -> [PackageCheck]-checkNewLicense _pkg lic = catMaybes-    [ check (lic == SPDX.NONE) $-        PackageDistInexcusable-            "The 'license' field is missing or is NONE."-    ]--checkOldLicense :: PackageDescription -> License -> [PackageCheck]-checkOldLicense pkg lic = catMaybes-  [ check (lic == UnspecifiedLicense) $-      PackageDistInexcusable-        "The 'license' field is missing."--  , check (lic == AllRightsReserved) $-      PackageDistSuspicious-        "The 'license' is AllRightsReserved. Is that really what you want?"--  , checkVersion CabalSpecV1_4 (lic `notElem` compatLicenses) $-      PackageDistInexcusable $-           "Unfortunately the license " ++ quote (prettyShow (license pkg))-        ++ " messes up the parser in earlier Cabal versions so you need to "-        ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "-        ++ "compatibility with earlier Cabal versions then use 'OtherLicense'."--  , case lic of-      UnknownLicense l -> Just $-        PackageBuildWarning $-             quote ("license: " ++ l) ++ " is not a recognised license. The "-          ++ "known licenses are: "-          ++ commaSep (map prettyShow knownLicenses)-      _ -> Nothing--  , check (lic == BSD4) $-      PackageDistSuspicious $-           "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' "-        ++ "refers to the old 4-clause BSD license with the advertising "-        ++ "clause. 'BSD3' refers the new 3-clause BSD license."--  , case unknownLicenseVersion (lic) of-      Just knownVersions -> Just $-        PackageDistSuspicious $-             "'license: " ++ prettyShow (lic) ++ "' is not a known "-          ++ "version of that license. The known versions are "-          ++ commaSep (map prettyShow knownVersions)-          ++ ". If this is not a mistake and you think it should be a known "-          ++ "version then please file a ticket."-      _ -> Nothing--  , check (lic `notElem` [ AllRightsReserved-                                 , UnspecifiedLicense, PublicDomain]-           -- AllRightsReserved and PublicDomain are not strictly-           -- licenses so don't need license files.-        && null (licenseFiles pkg)) $-      PackageDistSuspicious "A 'license-file' is not specified."-  ]-  where-    unknownLicenseVersion (GPL  (Just v))-      | v `notElem` knownVersions = Just knownVersions-      where knownVersions = [ v' | GPL  (Just v') <- knownLicenses ]-    unknownLicenseVersion (LGPL (Just v))-      | v `notElem` knownVersions = Just knownVersions-      where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ]-    unknownLicenseVersion (AGPL (Just v))-      | v `notElem` knownVersions = Just knownVersions-      where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ]-    unknownLicenseVersion (Apache  (Just v))-      | v `notElem` knownVersions = Just knownVersions-      where knownVersions = [ v' | Apache  (Just v') <- knownLicenses ]-    unknownLicenseVersion _ = Nothing--    checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck-    checkVersion ver cond pc-      | specVersion pkg >= ver  = Nothing-      | otherwise               = check cond pc--    compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4-                     , PublicDomain, AllRightsReserved-                     , UnspecifiedLicense, OtherLicense ]--checkSourceRepos :: PackageDescription -> [PackageCheck]-checkSourceRepos pkg =-  catMaybes $ concat [[--    case repoKind repo of-      RepoKindUnknown kind -> Just $ PackageDistInexcusable $-        quote kind ++ " is not a recognised kind of source-repository. "-                   ++ "The repo kind is usually 'head' or 'this'"-      _ -> Nothing--  , check (isNothing (repoType repo)) $-      PackageDistInexcusable-        "The source-repository 'type' is a required field."--  , check (isNothing (repoLocation repo)) $-      PackageDistInexcusable-        "The source-repository 'location' is a required field."--  , check (repoType repo == Just (KnownRepoType CVS) && isNothing (repoModule repo)) $-      PackageDistInexcusable-        "For a CVS source-repository, the 'module' is a required field."--  , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $-      PackageDistInexcusable $-           "For the 'this' kind of source-repository, the 'tag' is a required "-        ++ "field. It should specify the tag corresponding to this version "-        ++ "or release of the package."--  , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $-      PackageDistInexcusable-        "The 'subdir' field of a source-repository must be a relative path."--  , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $-      PackageDistInexcusable-        "The 'subdir' field of a source-repository must be a relative path."--  , do-      subdir <- repoSubdir repo-      err    <- isGoodRelativeDirectoryPath subdir-      return $ PackageDistInexcusable $-        "The 'subdir' field of a source-repository is not a good relative path: " ++ show err-  ]-  | repo <- sourceRepos pkg ]----TODO: check location looks like a URL for some repo types.---- | Checks GHC options from all ghc-*-options fields in the given--- PackageDescription and reports commonly misused or non-portable flags-checkAllGhcOptions :: PackageDescription -> [PackageCheck]-checkAllGhcOptions pkg =-    checkGhcOptions "ghc-options" (hcOptions GHC) pkg- ++ checkGhcOptions "ghc-prof-options" (hcProfOptions GHC) pkg- ++ checkGhcOptions "ghc-shared-options" (hcSharedOptions GHC) pkg---- | Extracts GHC options belonging to the given field from the given--- PackageDescription using given function and checks them for commonly misused--- or non-portable flags-checkGhcOptions :: String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck]-checkGhcOptions fieldName getOptions pkg =-  catMaybes [--    checkFlags ["-fasm"] $-      PackageDistInexcusable $-           "'" ++ fieldName ++ ": -fasm' is unnecessary and will not work on CPU "-        ++ "architectures other than x86, x86-64, ppc or sparc."--  , checkFlags ["-fvia-C"] $-      PackageDistSuspicious $-           "'" ++ fieldName ++": -fvia-C' is usually unnecessary. If your package "-        ++ "needs -via-C for correctness rather than performance then it "-        ++ "is using the FFI incorrectly and will probably not work with GHC "-        ++ "6.10 or later."--  , checkFlags ["-fhpc"] $-      PackageDistInexcusable $-           "'" ++ fieldName ++ ": -fhpc' is not necessary. Use the configure flag "-        ++ " --enable-coverage instead."--  , checkFlags ["-prof"] $-      PackageBuildWarning $-           "'" ++ fieldName ++ ": -prof' is not necessary and will lead to problems "-        ++ "when used on a library. Use the configure flag "-        ++ "--enable-library-profiling and/or --enable-profiling."--  , checkFlags ["-o"] $-      PackageBuildWarning $-           "'" ++ fieldName ++ ": -o' is not needed. "-        ++ "The output files are named automatically."--  , checkFlags ["-hide-package"] $-      PackageBuildWarning $-      "'" ++ fieldName ++ ": -hide-package' is never needed. "-      ++ "Cabal hides all packages."--  , checkFlags ["--make"] $-      PackageBuildWarning $-      "'" ++ fieldName ++ ": --make' is never needed. Cabal uses this automatically."--  , checkFlags ["-main-is"] $-      PackageDistSuspicious $-      "'" ++ fieldName ++ ": -main-is' is not portable."--  , checkNonTestAndBenchmarkFlags ["-O0", "-Onot"] $-      PackageDistSuspicious $-      "'" ++ fieldName ++ ": -O0' is not needed. "-      ++ "Use the --disable-optimization configure flag."--  , checkTestAndBenchmarkFlags ["-O0", "-Onot"] $-      PackageDistSuspiciousWarn $-      "'" ++ fieldName ++ ": -O0' is not needed. "-      ++ "Use the --disable-optimization configure flag."--  , checkFlags [ "-O", "-O1"] $-      PackageDistInexcusable $-      "'" ++ fieldName ++ ": -O' is not needed. "-      ++ "Cabal automatically adds the '-O' flag. "-      ++ "Setting it yourself interferes with the --disable-optimization flag."--  , checkFlags ["-O2"] $-      PackageDistSuspiciousWarn $-      "'" ++ fieldName ++ ": -O2' is rarely needed. "-      ++ "Check that it is giving a real benefit "-      ++ "and not just imposing longer compile times on your users."--  , checkFlags ["-split-sections"] $-      PackageBuildWarning $-        "'" ++ fieldName ++ ": -split-sections' is not needed. "-        ++ "Use the --enable-split-sections configure flag."--  , checkFlags ["-split-objs"] $-      PackageBuildWarning $-        "'" ++ fieldName ++ ": -split-objs' is not needed. "-        ++ "Use the --enable-split-objs configure flag."--  , checkFlags ["-optl-Wl,-s", "-optl-s"] $-      PackageDistInexcusable $-           "'" ++ fieldName ++ ": -optl-Wl,-s' is not needed and is not portable to all"-        ++ " operating systems. Cabal 1.4 and later automatically strip"-        ++ " executables. Cabal also has a flag --disable-executable-stripping"-        ++ " which is necessary when building packages for some Linux"-        ++ " distributions and using '-optl-Wl,-s' prevents that from working."--  , checkFlags ["-fglasgow-exts"] $-      PackageDistSuspicious $-        "Instead of '" ++ fieldName ++ ": -fglasgow-exts' it is preferable to use "-        ++ "the 'extensions' field."--  , check ("-threaded" `elem` lib_ghc_options) $-      PackageBuildWarning $-           "'" ++ fieldName ++ ": -threaded' has no effect for libraries. It should "-        ++ "only be used for executables."--  , check ("-rtsopts" `elem` lib_ghc_options) $-      PackageBuildWarning $-           "'" ++ fieldName ++ ": -rtsopts' has no effect for libraries. It should "-        ++ "only be used for executables."--  , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $-      PackageBuildWarning $-           "'" ++ fieldName ++ ": -with-rtsopts' has no effect for libraries. It "-        ++ "should only be used for executables."--  , checkAlternatives fieldName "extensions"-      [ (flag, prettyShow extension) | flag <- all_ghc_options-                                  , Just extension <- [ghcExtension flag] ]--  , checkAlternatives fieldName "extensions"-      [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ]--  , checkAlternatives fieldName "cpp-options" $-         [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ]-      ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ]--  , checkAlternatives fieldName "include-dirs"-      [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ]--  , checkAlternatives fieldName "extra-libraries"-      [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ]--  , checkAlternatives fieldName "extra-lib-dirs"-      [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ]--  , checkAlternatives fieldName "frameworks"-      [ (flag, fmwk) | (flag@"-framework", fmwk) <--           zip all_ghc_options (safeTail all_ghc_options) ]--  , checkAlternatives fieldName "extra-framework-dirs"-      [ (flag, dir) | (flag@"-framework-path", dir) <--           zip all_ghc_options (safeTail all_ghc_options) ]-  ]--  where-    all_ghc_options    = concatMap getOptions (allBuildInfo pkg)-    lib_ghc_options    = concatMap (getOptions . libBuildInfo)-                         (allLibraries pkg)-    test_ghc_options      = concatMap (getOptions . testBuildInfo)-                            (testSuites pkg)-    benchmark_ghc_options = concatMap (getOptions . benchmarkBuildInfo)-                            (benchmarks pkg)-    test_and_benchmark_ghc_options     = test_ghc_options ++-                                         benchmark_ghc_options-    non_test_and_benchmark_ghc_options = concatMap getOptions-                                         (allBuildInfo (pkg { testSuites = []-                                                            , benchmarks = []-                                                            }))--    checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck-    checkFlags flags = check (any (`elem` flags) all_ghc_options)--    checkTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck-    checkTestAndBenchmarkFlags flags = check (any (`elem` flags) test_and_benchmark_ghc_options)--    checkNonTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck-    checkNonTestAndBenchmarkFlags flags = check (any (`elem` flags) non_test_and_benchmark_ghc_options)--    ghcExtension ('-':'f':name) = case name of-      "allow-overlapping-instances"    -> enable  OverlappingInstances-      "no-allow-overlapping-instances" -> disable OverlappingInstances-      "th"                             -> enable  TemplateHaskell-      "no-th"                          -> disable TemplateHaskell-      "ffi"                            -> enable  ForeignFunctionInterface-      "no-ffi"                         -> disable ForeignFunctionInterface-      "fi"                             -> enable  ForeignFunctionInterface-      "no-fi"                          -> disable ForeignFunctionInterface-      "monomorphism-restriction"       -> enable  MonomorphismRestriction-      "no-monomorphism-restriction"    -> disable MonomorphismRestriction-      "mono-pat-binds"                 -> enable  MonoPatBinds-      "no-mono-pat-binds"              -> disable MonoPatBinds-      "allow-undecidable-instances"    -> enable  UndecidableInstances-      "no-allow-undecidable-instances" -> disable UndecidableInstances-      "allow-incoherent-instances"     -> enable  IncoherentInstances-      "no-allow-incoherent-instances"  -> disable IncoherentInstances-      "arrows"                         -> enable  Arrows-      "no-arrows"                      -> disable Arrows-      "generics"                       -> enable  Generics-      "no-generics"                    -> disable Generics-      "implicit-prelude"               -> enable  ImplicitPrelude-      "no-implicit-prelude"            -> disable ImplicitPrelude-      "implicit-params"                -> enable  ImplicitParams-      "no-implicit-params"             -> disable ImplicitParams-      "bang-patterns"                  -> enable  BangPatterns-      "no-bang-patterns"               -> disable BangPatterns-      "scoped-type-variables"          -> enable  ScopedTypeVariables-      "no-scoped-type-variables"       -> disable ScopedTypeVariables-      "extended-default-rules"         -> enable  ExtendedDefaultRules-      "no-extended-default-rules"      -> disable ExtendedDefaultRules-      _                                -> Nothing-    ghcExtension "-cpp"             = enable CPP-    ghcExtension _                  = Nothing--    enable  e = Just (EnableExtension e)-    disable e = Just (DisableExtension e)--checkCCOptions :: PackageDescription -> [PackageCheck]-checkCCOptions = checkCLikeOptions "C" "cc-options" ccOptions--checkCxxOptions :: PackageDescription -> [PackageCheck]-checkCxxOptions = checkCLikeOptions "C++" "cxx-options" cxxOptions--checkCLikeOptions :: String -> String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck]-checkCLikeOptions label prefix accessor pkg =-  catMaybes [--    checkAlternatives prefix "include-dirs"-      [ (flag, dir) | flag@('-':'I':dir) <- all_cLikeOptions ]--  , checkAlternatives prefix "extra-libraries"-      [ (flag, lib) | flag@('-':'l':lib) <- all_cLikeOptions ]--  , checkAlternatives prefix "extra-lib-dirs"-      [ (flag, dir) | flag@('-':'L':dir) <- all_cLikeOptions ]--  , checkAlternatives "ld-options" "extra-libraries"-      [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ]--  , checkAlternatives "ld-options" "extra-lib-dirs"-      [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ]--  , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $-      PackageDistSuspicious $-           "'"++prefix++": -O[n]' is generally not needed. When building with "-        ++ " optimisations Cabal automatically adds '-O2' for "++label++" code. "-        ++ "Setting it yourself interferes with the --disable-optimization flag."-  ]--  where all_cLikeOptions = [ opts | bi <- allBuildInfo pkg-                                  , opts <- accessor bi ]-        all_ldOptions = [ opts | bi <- allBuildInfo pkg-                               , opts <- ldOptions bi ]--        checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck-        checkCCFlags flags = check (any (`elem` flags) all_cLikeOptions)--checkCPPOptions :: PackageDescription -> [PackageCheck]-checkCPPOptions pkg = catMaybes-    [ checkAlternatives "cpp-options" "include-dirs"-      [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions ]-    ]-    ++-    [ PackageBuildWarning $ "'cpp-options': " ++ opt ++ " is not portable C-preprocessor flag"-    | opt <- all_cppOptions-    -- "-I" is handled above, we allow only -DNEWSTUFF and -UOLDSTUFF-    , not $ any (`isPrefixOf` opt) ["-D", "-U", "-I" ]-    ]-  where-    all_cppOptions = [ opts | bi <- allBuildInfo pkg, opts <- cppOptions bi ]--checkAlternatives :: String -> String -> [(String, String)]-                  -> Maybe PackageCheck-checkAlternatives badField goodField flags =-  check (not (null badFlags)) $-    PackageBuildWarning $-         "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags)-      ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags)--  where (badFlags, goodFlags) = unzip flags--data PathKind-    = PathKindFile-    | PathKindDirectory-    | PathKindGlob--checkPaths :: PackageDescription -> [PackageCheck]-checkPaths pkg =-  [ PackageBuildWarning $-         quote (field ++ ": " ++ path)-      ++ " is a relative path outside of the source tree. "-      ++ "This will not work when generating a tarball with 'sdist'."-  | (path, field, _) <- relPaths ++ absPaths-  , isOutsideTree path ]-  ++-  [ PackageDistInexcusable $-      quote (field ++ ": " ++ path) ++ " is an absolute path."-  | (path, field, _) <- relPaths-  , isAbsoluteOnAnyPlatform path ]-  ++-  [ PackageDistInexcusable $-      quote (field ++ ": " ++ path) ++ " is not good relative path: " ++ err-  | (path, field, kind) <- relPaths-  -- these are not paths, but globs...-  , err <- maybeToList $ case kind of-      PathKindFile      -> isGoodRelativeFilePath path-      PathKindGlob      -> isGoodRelativeGlob path-      PathKindDirectory -> isGoodRelativeDirectoryPath path-  ]-  ++-  [ PackageDistInexcusable $-         quote (field ++ ": " ++ path) ++ " points inside the 'dist' "-      ++ "directory. This is not reliable because the location of this "-      ++ "directory is configurable by the user (or package manager). In "-      ++ "addition the layout of the 'dist' directory is subject to change "-      ++ "in future versions of Cabal."-  | (path, field, _) <- relPaths ++ absPaths-  , isInsideDist path ]-  ++-  [ PackageDistInexcusable $-         "The 'ghc-options' contains the path '" ++ path ++ "' which points "-      ++ "inside the 'dist' directory. This is not reliable because the "-      ++ "location of this directory is configurable by the user (or package "-      ++ "manager). In addition the layout of the 'dist' directory is subject "-      ++ "to change in future versions of Cabal."-  | bi <- allBuildInfo pkg-  , (GHC, flags) <- perCompilerFlavorToList $ options bi-  , path <- flags-  , isInsideDist path ]-  ++-  [ PackageDistInexcusable $-        "In the 'data-files' field: " ++ explainGlobSyntaxError pat err-  | pat <- dataFiles pkg-  , Left err <- [parseFileGlob (specVersion pkg) pat]-  ]-  ++-  [ PackageDistInexcusable $-        "In the 'extra-source-files' field: " ++ explainGlobSyntaxError pat err-  | pat <- extraSrcFiles pkg-  , Left err <- [parseFileGlob (specVersion pkg) pat]-  ]-  ++-  [ PackageDistInexcusable $-        "In the 'extra-doc-files' field: " ++ explainGlobSyntaxError pat err-  | pat <- extraDocFiles pkg-  , Left err <- [parseFileGlob (specVersion pkg) pat]-  ]-  where-    isOutsideTree path = case splitDirectories path of-      "..":_     -> True-      ".":"..":_ -> True-      _          -> False-    isInsideDist path = case map lowercase (splitDirectories path) of-      "dist"    :_ -> True-      ".":"dist":_ -> True-      _            -> False--    -- paths that must be relative-    relPaths :: [(FilePath, String, PathKind)]-    relPaths =-      [ (path, "extra-source-files", PathKindGlob)      | path <- extraSrcFiles pkg ] ++-      [ (path, "extra-tmp-files",    PathKindFile)      | path <- extraTmpFiles pkg ] ++-      [ (path, "extra-doc-files",    PathKindGlob)      | path <- extraDocFiles pkg ] ++-      [ (path, "data-files",         PathKindGlob)      | path <- dataFiles     pkg ] ++-      [ (path, "data-dir",           PathKindDirectory) | path <- [dataDir      pkg]] ++-      [ (path, "license-file",       PathKindFile)      | path <- map getSymbolicPath $ licenseFiles  pkg ] ++-      concat-        [ [ (path, "asm-sources",      PathKindFile)      | path <- asmSources      bi ] ++-          [ (path, "cmm-sources",      PathKindFile)      | path <- cmmSources      bi ] ++-          [ (path, "c-sources",        PathKindFile)      | path <- cSources        bi ] ++-          [ (path, "cxx-sources",      PathKindFile)      | path <- cxxSources      bi ] ++-          [ (path, "js-sources",       PathKindFile)      | path <- jsSources       bi ] ++-          [ (path, "install-includes", PathKindFile)      | path <- installIncludes bi ] ++-          [ (path, "hs-source-dirs",   PathKindDirectory) | path <- map getSymbolicPath $ hsSourceDirs bi ]-        | bi <- allBuildInfo pkg-        ]--    -- paths that are allowed to be absolute-    absPaths :: [(FilePath, String, PathKind)]-    absPaths = concat-      [ [ (path, "includes",       PathKindFile)      | path <- includes     bi ] ++-        [ (path, "include-dirs",   PathKindDirectory) | path <- includeDirs  bi ] ++-        [ (path, "extra-lib-dirs", PathKindDirectory) | path <- extraLibDirs bi ]-      | bi <- allBuildInfo pkg-      ]----TODO: check sets of paths that would be interpreted differently between Unix--- and windows, ie case-sensitive or insensitive. Things that might clash, or--- conversely be distinguished.----TODO: use the tar path checks on all the above paths---- | Check that the package declares the version in the @\"cabal-version\"@--- field correctly.----checkCabalVersion :: PackageDescription -> [PackageCheck]-checkCabalVersion pkg =-  catMaybes [--    -- check use of test suite sections-    checkVersion CabalSpecV1_8 (not (null $ testSuites pkg)) $-      PackageDistInexcusable $-           "The 'test-suite' section is new in Cabal 1.10. "-        ++ "Unfortunately it messes up the parser in older Cabal versions "-        ++ "so you must specify at least 'cabal-version: >= 1.8', but note "-        ++ "that only Cabal 1.10 and later can actually run such test suites."--    -- check use of default-language field-    -- note that we do not need to do an equivalent check for the-    -- other-language field since that one does not change behaviour-  , checkVersion CabalSpecV1_10 (any isJust (buildInfoField defaultLanguage)) $-      PackageBuildWarning $-           "To use the 'default-language' field the package needs to specify "-        ++ "at least 'cabal-version: >= 1.10'."--  , check (specVersion pkg >= CabalSpecV1_10 && specVersion pkg < CabalSpecV3_4-           && (any isNothing (buildInfoField defaultLanguage))) $-      PackageBuildWarning $-           "Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' must specify the "-        ++ "'default-language' field for each component (e.g. Haskell98 or "-        ++ "Haskell2010). If a component uses different languages in "-        ++ "different modules then list the other ones in the "-        ++ "'other-languages' field."--  , checkVersion CabalSpecV1_18-    (not . null $ extraDocFiles pkg) $-      PackageDistInexcusable $-           "To use the 'extra-doc-files' field the package needs to specify "-        ++ "at least 'cabal-version: >= 1.18'."--  , checkVersion CabalSpecV2_0-    (not (null (subLibraries pkg))) $-      PackageDistInexcusable $-           "To use multiple 'library' sections or a named library section "-        ++ "the package needs to specify at least 'cabal-version: 2.0'."--    -- check use of reexported-modules sections-  , checkVersion CabalSpecV1_22-    (any (not.null.reexportedModules) (allLibraries pkg)) $-      PackageDistInexcusable $-           "To use the 'reexported-module' field the package needs to specify "-        ++ "at least 'cabal-version: >= 1.22'."--    -- check use of thinning and renaming-  , checkVersion CabalSpecV2_0 usesBackpackIncludes $-      PackageDistInexcusable $-           "To use the 'mixins' field the package needs to specify "-        ++ "at least 'cabal-version: 2.0'."--    -- check use of 'extra-framework-dirs' field-  , checkVersion CabalSpecV1_24 (any (not . null) (buildInfoField extraFrameworkDirs)) $-      -- Just a warning, because this won't break on old Cabal versions.-      PackageDistSuspiciousWarn $-           "To use the 'extra-framework-dirs' field the package needs to specify"-        ++ " at least 'cabal-version: >= 1.24'."--    -- check use of default-extensions field-    -- don't need to do the equivalent check for other-extensions-  , checkVersion CabalSpecV1_10 (any (not . null) (buildInfoField defaultExtensions)) $-      PackageBuildWarning $-           "To use the 'default-extensions' field the package needs to specify "-        ++ "at least 'cabal-version: >= 1.10'."--    -- check use of extensions field-  , check (specVersion pkg >= CabalSpecV1_10-           && (any (not . null) (buildInfoField oldExtensions))) $-      PackageBuildWarning $-           "For packages using 'cabal-version: >= 1.10' the 'extensions' "-        ++ "field is deprecated. The new 'default-extensions' field lists "-        ++ "extensions that are used in all modules in the component, while "-        ++ "the 'other-extensions' field lists extensions that are used in "-        ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma."--  , checkVersion CabalSpecV3_0 (any (not . null)-                        (concatMap buildInfoField-                         [ asmSources-                         , cmmSources-                         , extraBundledLibs-                         , extraLibFlavours ])) $-      PackageDistInexcusable $-           "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' "-        ++ " and 'extra-library-flavours' requires the package "-        ++ " to specify at least 'cabal-version: 3.0'."--  , checkVersion CabalSpecV3_0 (any (not . null) $ buildInfoField extraDynLibFlavours) $-      PackageDistInexcusable $-           "The use of 'extra-dynamic-library-flavours' requires the package "-        ++ " to specify at least 'cabal-version: 3.0'. The flavours are: "-        ++ commaSep [ flav-                    | flavs <- buildInfoField extraDynLibFlavours-                    , flav <- flavs ]--  , checkVersion CabalSpecV2_2 (any (not . null)-                        (buildInfoField virtualModules)) $-      PackageDistInexcusable $-           "The use of 'virtual-modules' requires the package "-        ++ " to specify at least 'cabal-version: 2.2'."--    -- check use of "source-repository" section-  , checkVersion CabalSpecV1_6 (not (null (sourceRepos pkg))) $-      PackageDistInexcusable $-           "The 'source-repository' section is new in Cabal 1.6. "-        ++ "Unfortunately it messes up the parser in earlier Cabal versions "-        ++ "so you need to specify 'cabal-version: >= 1.6'."--    -- check for new language extensions-  , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal12)) $-      PackageDistInexcusable $-           "Unfortunately the language extensions "-        ++ commaSep (map (quote . prettyShow) mentionedExtensionsThatNeedCabal12)-        ++ " break the parser in earlier Cabal versions so you need to "-        ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "-        ++ "compatibility with earlier Cabal versions then you may be able to "-        ++ "use an equivalent compiler-specific flag."--  , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal14)) $-      PackageDistInexcusable $-           "Unfortunately the language extensions "-        ++ commaSep (map (quote . prettyShow) mentionedExtensionsThatNeedCabal14)-        ++ " break the parser in earlier Cabal versions so you need to "-        ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "-        ++ "compatibility with earlier Cabal versions then you may be able to "-        ++ "use an equivalent compiler-specific flag."--  , check (specVersion pkg >= CabalSpecV1_24-           && isNothing (setupBuildInfo pkg)-           && buildType pkg == Custom) $-      PackageBuildWarning $-           "Packages using 'cabal-version: >= 1.24' with 'build-type: Custom' "-        ++ "must use a 'custom-setup' section with a 'setup-depends' field "-        ++ "that specifies the dependencies of the Setup.hs script itself. "-        ++ "The 'setup-depends' field uses the same syntax as 'build-depends', "-        ++ "so a simple example would be 'setup-depends: base, Cabal'."--  , check (specVersion pkg < CabalSpecV1_24-           && isNothing (setupBuildInfo pkg)-           && buildType pkg == Custom) $-      PackageDistSuspiciousWarn $-           "From version 1.24 cabal supports specifying explicit dependencies "-        ++ "for Custom setup scripts. Consider using cabal-version >= 1.24 and "-        ++ "adding a 'custom-setup' section with a 'setup-depends' field "-        ++ "that specifies the dependencies of the Setup.hs script itself. "-        ++ "The 'setup-depends' field uses the same syntax as 'build-depends', "-        ++ "so a simple example would be 'setup-depends: base, Cabal'."--  , check (specVersion pkg >= CabalSpecV2_0-           && elem (autogenPathsModuleName pkg) allModuleNames-           && not (elem (autogenPathsModuleName pkg) allModuleNamesAutogen) ) $-      PackageDistInexcusable $-           "Packages using 'cabal-version: 2.0' and the autogenerated "-        ++ "module Paths_* must include it also on the 'autogen-modules' field "-        ++ "besides 'exposed-modules' and 'other-modules'. This specifies that "-        ++ "the module does not come with the package and is generated on "-        ++ "setup. Modules built with a custom Setup.hs script also go here "-        ++ "to ensure that commands like sdist don't fail."--  ]-  where-    -- Perform a check on packages that use a version of the spec less than-    -- the version given. This is for cases where a new Cabal version adds-    -- a new feature and we want to check that it is not used prior to that-    -- version.-    checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck-    checkVersion ver cond pc-      | specVersion pkg >= ver = Nothing-      | otherwise              = check cond pc--    buildInfoField field         = map field (allBuildInfo pkg)--    usesBackpackIncludes = any (not . null . mixins) (allBuildInfo pkg)--    mentionedExtensions = [ ext | bi <- allBuildInfo pkg-                                , ext <- allExtensions bi ]-    mentionedExtensionsThatNeedCabal12 =-      nub (filter (`elem` compatExtensionsExtra) mentionedExtensions)--    -- As of Cabal-1.4 we can add new extensions without worrying about-    -- breaking old versions of cabal.-    mentionedExtensionsThatNeedCabal14 =-      nub (filter (`notElem` compatExtensions) mentionedExtensions)--    -- The known extensions in Cabal-1.2.3-    compatExtensions =-      map EnableExtension-      [ OverlappingInstances, UndecidableInstances, IncoherentInstances-      , RecursiveDo, ParallelListComp, MultiParamTypeClasses-      , FunctionalDependencies, Rank2Types-      , RankNTypes, PolymorphicComponents, ExistentialQuantification-      , ScopedTypeVariables, ImplicitParams, FlexibleContexts-      , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns-      , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface-      , Arrows, Generics, NamedFieldPuns, PatternGuards-      , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms-      , HereDocuments] ++-      map DisableExtension-      [MonomorphismRestriction, ImplicitPrelude] ++-      compatExtensionsExtra--    -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6-    -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8)-    compatExtensionsExtra =-      map EnableExtension-      [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving-      , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms-      , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields-      , OverloadedStrings, GADTs, RelaxedPolyRec-      , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable-      , ConstrainedClassMethods-      ] ++-      map DisableExtension-      [MonoPatBinds]--    allModuleNames =-         (case library pkg of-           Nothing -> []-           (Just lib) -> explicitLibModules lib-         )-      ++ concatMap otherModules (allBuildInfo pkg)--    allModuleNamesAutogen = concatMap autogenModules (allBuildInfo pkg)---- --------------------------------------------------------------- * Checks on the GenericPackageDescription--- ---------------------------------------------------------------- | Check the build-depends fields for any weirdness or bad practice.----checkPackageVersions :: GenericPackageDescription -> [PackageCheck]-checkPackageVersions pkg =-  catMaybes [--    -- Check that the version of base is bounded above.-    -- For example this bans "build-depends: base >= 3".-    -- It should probably be "build-depends: base >= 3 && < 4"-    -- which is the same as  "build-depends: base == 3.*"-    check (not (boundedAbove baseDependency)) $-      PackageDistInexcusable $-           "The dependency 'build-depends: base' does not specify an upper "-        ++ "bound on the version number. Each major release of the 'base' "-        ++ "package changes the API in various ways and most packages will "-        ++ "need some changes to compile with it. The recommended practice "-        ++ "is to specify an upper bound on the version of the 'base' "-        ++ "package. This ensures your package will continue to build when a "-        ++ "new major version of the 'base' package is released. If you are "-        ++ "not sure what upper bound to use then use the next  major "-        ++ "version. For example if you have tested your package with 'base' "-        ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'."--  ]-  where-    -- TODO: What we really want to do is test if there exists any-    -- configuration in which the base version is unbounded above.-    -- However that's a bit tricky because there are many possible-    -- configurations. As a cheap easy and safe approximation we will-    -- pick a single "typical" configuration and check if that has an-    -- open upper bound. To get a typical configuration we finalise-    -- using no package index and the current platform.-    finalised = finalizePD-                              mempty defaultComponentRequestedSpec (const True)-                              buildPlatform-                              (unknownCompilerInfo-                                (CompilerId buildCompilerFlavor nullVersion)-                                NoAbiTag)-                              [] pkg-    baseDependency = case finalised of-      Right (pkg', _) | not (null baseDeps) ->-          foldr intersectVersionRanges anyVersion baseDeps-        where-          baseDeps =-            [ vr | Dependency pname vr _ <- allBuildDepends pkg'-                 , pname == mkPackageName "base" ]--      -- Just in case finalizePD fails for any reason,-      -- or if the package doesn't depend on the base package at all,-      -- then we will just skip the check, since boundedAbove noVersion = True-      _          -> noVersion--    -- TODO: move to Distribution.Version-    boundedAbove :: VersionRange -> Bool-    boundedAbove vr = case asVersionIntervals vr of-      []     -> True -- this is the inconsistent version range.-      (x:xs) -> case last (x:|xs) of-        VersionInterval _ UpperBound {} -> True-        VersionInterval _ NoUpperBound  -> False---checkConditionals :: GenericPackageDescription -> [PackageCheck]-checkConditionals pkg =-  catMaybes [--    check (not $ null unknownOSs) $-      PackageDistInexcusable $-           "Unknown operating system name "-        ++ commaSep (map quote unknownOSs)--  , check (not $ null unknownArches) $-      PackageDistInexcusable $-           "Unknown architecture name "-        ++ commaSep (map quote unknownArches)--  , check (not $ null unknownImpls) $-      PackageDistInexcusable $-           "Unknown compiler name "-        ++ commaSep (map quote unknownImpls)-  ]-  where-    unknownOSs    = [ os   | OS   (OtherOS os)           <- conditions ]-    unknownArches = [ arch | Arch (OtherArch arch)       <- conditions ]-    unknownImpls  = [ impl | Impl (OtherCompiler impl) _ <- conditions ]-    conditions = concatMap fvs (maybeToList (condLibrary pkg))-              ++ concatMap (fvs . snd) (condSubLibraries pkg)-              ++ concatMap (fvs . snd) (condForeignLibs pkg)-              ++ concatMap (fvs . snd) (condExecutables pkg)-              ++ concatMap (fvs . snd) (condTestSuites pkg)-              ++ concatMap (fvs . snd) (condBenchmarks pkg)-    fvs (CondNode _ _ ifs) = concatMap compfv ifs -- free variables-    compfv (CondBranch c ct mct) = condfv c ++ fvs ct ++ maybe [] fvs mct-    condfv c = case c of-      Var v      -> [v]-      Lit _      -> []-      CNot c1    -> condfv c1-      COr  c1 c2 -> condfv c1 ++ condfv c2-      CAnd c1 c2 -> condfv c1 ++ condfv c2--checkFlagNames :: GenericPackageDescription -> [PackageCheck]-checkFlagNames gpd-    | null invalidFlagNames = []-    | otherwise             = [ PackageDistInexcusable-        $ "Suspicious flag names: " ++ unwords invalidFlagNames ++ ". "-        ++ "To avoid ambiguity in command line interfaces, flag shouldn't "-        ++ "start with a dash. Also for better compatibility, flag names "-        ++ "shouldn't contain non-ascii characters."-        ]-  where-    invalidFlagNames =-        [ fn-        | flag <- genPackageFlags gpd-        , let fn = unFlagName (flagName flag)-        , invalidFlagName fn-        ]-    -- starts with dash-    invalidFlagName ('-':_) = True-    -- mon ascii letter-    invalidFlagName cs = any (not . isAscii) cs--checkUnusedFlags :: GenericPackageDescription -> [PackageCheck]-checkUnusedFlags gpd-    | declared == used = []-    | otherwise        = [ PackageDistSuspicious-        $ "Declared and used flag sets differ: "-        ++ s declared ++ " /= " ++ s used ++ ". "-        ]-  where-    s :: Set.Set FlagName -> String-    s = commaSep . map unFlagName . Set.toList--    declared :: Set.Set FlagName-    declared = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd--    used :: Set.Set FlagName-    used = mconcat-        [ toSetOf (L.condLibrary      . traverse      . traverseCondTreeV . L._PackageFlag) gpd-        , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd-        , toSetOf (L.condForeignLibs  . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd-        , toSetOf (L.condExecutables  . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd-        , toSetOf (L.condTestSuites   . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd-        , toSetOf (L.condBenchmarks   . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd-        ]--checkUnicodeXFields :: GenericPackageDescription -> [PackageCheck]-checkUnicodeXFields gpd-    | null nonAsciiXFields = []-    | otherwise            = [ PackageDistInexcusable-        $ "Non ascii custom fields: " ++ unwords nonAsciiXFields ++ ". "-        ++ "For better compatibility, custom field names "-        ++ "shouldn't contain non-ascii characters."-        ]-  where-    nonAsciiXFields :: [String]-    nonAsciiXFields = [ n | (n, _) <- xfields, any (not . isAscii) n ]--    xfields :: [(String,String)]-    xfields = DList.runDList $ mconcat-        [ toDListOf (L.packageDescription . L.customFieldsPD . traverse) gpd-        , toDListOf (L.traverseBuildInfos . L.customFieldsBI . traverse) gpd-        ]---- | cabal-version <2.2 + Paths_module + default-extensions: doesn't build.-checkPathsModuleExtensions :: PackageDescription -> [PackageCheck]-checkPathsModuleExtensions pd-    | specVersion pd >= CabalSpecV2_2 = []-    | any checkBI (allBuildInfo pd) || any checkLib (allLibraries pd)-        = return $ PackageBuildImpossible $ unwords-            [ "The package uses RebindableSyntax with OverloadedStrings or OverloadedLists"-            , "in default-extensions, and also Paths_ autogen module."-            , "That configuration is known to cause compile failures with Cabal < 2.2."-            , "To use these default-extensions with Paths_ autogen module"-            , "specify at least 'cabal-version: 2.2'."-            ]-    | otherwise = []-  where-    mn = autogenPathsModuleName pd--    checkLib :: Library -> Bool-    checkLib l = mn `elem` exposedModules l && checkExts (l ^. L.defaultExtensions)--    checkBI :: BuildInfo -> Bool-    checkBI bi =-        (mn `elem` otherModules bi || mn `elem` autogenModules bi) &&-        checkExts (bi ^. L.defaultExtensions)--    checkExts exts = rebind `elem` exts && (strings `elem` exts || lists `elem` exts)-      where-        rebind  = EnableExtension RebindableSyntax-        strings = EnableExtension OverloadedStrings-        lists   = EnableExtension OverloadedLists---- | Checks GHC options from all ghc-*-options fields from the given BuildInfo--- and reports flags that are OK during development process, but are--- unacceptable in a distrubuted package-checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck]-checkDevelopmentOnlyFlagsBuildInfo bi =-    checkDevelopmentOnlyFlagsOptions "ghc-options" (hcOptions GHC bi)- ++ checkDevelopmentOnlyFlagsOptions "ghc-prof-options" (hcProfOptions GHC bi)- ++ checkDevelopmentOnlyFlagsOptions "ghc-shared-options" (hcSharedOptions GHC bi)---- | Checks the given list of flags belonging to the given field and reports--- flags that are OK during development process, but are unacceptable in a--- distributed package-checkDevelopmentOnlyFlagsOptions :: String -> [String] -> [PackageCheck]-checkDevelopmentOnlyFlagsOptions fieldName ghcOptions =-  catMaybes [--    check has_WerrorWall $-      PackageDistInexcusable $-           "'" ++ fieldName ++ ": -Wall -Werror' makes the package very easy to "-        ++ "break with future GHC versions because new GHC versions often "-        ++ "add new warnings. Use just '" ++ fieldName ++ ": -Wall' instead."-        ++ extraExplanation--  , check (not has_WerrorWall && has_Werror) $-      PackageDistInexcusable $-           "'" ++ fieldName ++ ": -Werror' makes the package easy to "-        ++ "break with future GHC versions because new GHC versions often "-        ++ "add new warnings. "-        ++ extraExplanation--  , check (has_J) $-      PackageDistInexcusable $-           "'" ++ fieldName ++ ": -j[N]' can make sense for specific user's setup,"-        ++ " but it is not appropriate for a distributed package."-        ++ extraExplanation--  , checkFlags ["-fdefer-type-errors"] $-      PackageDistInexcusable $-           "'" ++ fieldName ++ ": -fdefer-type-errors' is fine during development but "-        ++ "is not appropriate for a distributed package. "-        ++ extraExplanation--    -- -dynamic is not a debug flag-  , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic")-           ghcOptions) $-      PackageDistInexcusable $-           "'" ++ fieldName ++ ": -d*' debug flags are not appropriate "-        ++ "for a distributed package. "-        ++ extraExplanation--  , checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls",-               "-fprof-cafs", "-fno-prof-count-entries",-               "-auto-all", "-auto", "-caf-all"] $-      PackageDistSuspicious $-           "'" ++ fieldName ++ ": -fprof*' profiling flags are typically not "-        ++ "appropriate for a distributed library package. These flags are "-        ++ "useful to profile this package, but when profiling other packages "-        ++ "that use this one these flags clutter the profile output with "-        ++ "excessive detail. If you think other packages really want to see "-        ++ "cost centres from this package then use '-fprof-auto-exported' "-        ++ "which puts cost centres only on exported functions. "-        ++ extraExplanation-  ]-  where-    extraExplanation =-         " Alternatively, if you want to use this, make it conditional based "-      ++ "on a Cabal configuration flag (with 'manual: True' and 'default: "-      ++ "False') and enable that flag during development."--    has_WerrorWall   = has_Werror && ( has_Wall || has_W )-    has_Werror       = "-Werror" `elem` ghcOptions-    has_Wall         = "-Wall"   `elem` ghcOptions-    has_W            = "-W"      `elem` ghcOptions-    has_J            = any-                         (\o -> case o of-                           "-j"                -> True-                           ('-' : 'j' : d : _) -> isDigit d-                           _                   -> False-                         )-                         ghcOptions-    checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck-    checkFlags flags = check (any (`elem` flags) ghcOptions)--checkDevelopmentOnlyFlags :: GenericPackageDescription -> [PackageCheck]-checkDevelopmentOnlyFlags pkg =-    concatMap checkDevelopmentOnlyFlagsBuildInfo-              [ bi-              | (conditions, bi) <- allConditionalBuildInfo-              , not (any guardedByManualFlag conditions) ]-  where-    guardedByManualFlag = definitelyFalse--    -- We've basically got three-values logic here: True, False or unknown-    -- hence this pattern to propagate the unknown cases properly.-    definitelyFalse (Var (PackageFlag n)) = maybe False not (Map.lookup n manualFlags)-    definitelyFalse (Var _)        = False-    definitelyFalse (Lit  b)       = not b-    definitelyFalse (CNot c)       = definitelyTrue c-    definitelyFalse (COr  c1 c2)   = definitelyFalse c1 && definitelyFalse c2-    definitelyFalse (CAnd c1 c2)   = definitelyFalse c1 || definitelyFalse c2--    definitelyTrue (Var (PackageFlag n)) = fromMaybe False (Map.lookup n manualFlags)-    definitelyTrue (Var _)        = False-    definitelyTrue (Lit  b)       = b-    definitelyTrue (CNot c)       = definitelyFalse c-    definitelyTrue (COr  c1 c2)   = definitelyTrue c1 || definitelyTrue c2-    definitelyTrue (CAnd c1 c2)   = definitelyTrue c1 && definitelyTrue c2--    manualFlags = Map.fromList-                    [ (flagName flag, flagDefault flag)-                    | flag <- genPackageFlags pkg-                    , flagManual flag ]--    allConditionalBuildInfo :: [([Condition ConfVar], BuildInfo)]-    allConditionalBuildInfo =-        concatMap (collectCondTreePaths libBuildInfo)-                  (maybeToList (condLibrary pkg))--     ++ concatMap (collectCondTreePaths libBuildInfo . snd)-                  (condSubLibraries pkg)--     ++ concatMap (collectCondTreePaths buildInfo . snd)-                  (condExecutables pkg)--     ++ concatMap (collectCondTreePaths testBuildInfo . snd)-                  (condTestSuites pkg)--     ++ concatMap (collectCondTreePaths benchmarkBuildInfo . snd)-                  (condBenchmarks pkg)--    -- get all the leaf BuildInfo, paired up with the path (in the tree sense)-    -- of if-conditions that guard it-    collectCondTreePaths :: (a -> b)-                         -> CondTree v c a-                         -> [([Condition v], b)]-    collectCondTreePaths mapData = go []-      where-        go conditions condNode =-            -- the data at this level in the tree:-            (reverse conditions, mapData (condTreeData condNode))--          : concat-            [ go (condition:conditions) ifThen-            | (CondBranch condition ifThen _) <- condTreeComponents condNode ]--         ++ concat-            [ go (condition:conditions) elseThen-            | (CondBranch condition _ (Just elseThen)) <- condTreeComponents condNode ]----- --------------------------------------------------------------- * Checks involving files in the package--- ---------------------------------------------------------------- | Sanity check things that requires IO. It looks at the files in the--- package and expects to find the package unpacked in at the given file path.----checkPackageFiles :: Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck]-checkPackageFiles verbosity pkg root = do-  contentChecks <- checkPackageContent checkFilesIO pkg-  preDistributionChecks <- checkPackageFilesPreDistribution verbosity pkg root-  -- Sort because different platforms will provide files from-  -- `getDirectoryContents` in different orders, and we'd like to be-  -- stable for test output.-  return (sort contentChecks ++ sort preDistributionChecks)-  where-    checkFilesIO = CheckPackageContentOps {-      doesFileExist        = System.doesFileExist                  . relative,-      doesDirectoryExist   = System.doesDirectoryExist             . relative,-      getDirectoryContents = System.Directory.getDirectoryContents . relative,-      getFileContents      = BS.readFile                           . relative-    }-    relative path = root </> path---- | A record of operations needed to check the contents of packages.--- Used by 'checkPackageContent'.----data CheckPackageContentOps m = CheckPackageContentOps {-    doesFileExist        :: FilePath -> m Bool,-    doesDirectoryExist   :: FilePath -> m Bool,-    getDirectoryContents :: FilePath -> m [FilePath],-    getFileContents      :: FilePath -> m BS.ByteString-  }---- | Sanity check things that requires looking at files in the package.--- This is a generalised version of 'checkPackageFiles' that can work in any--- monad for which you can provide 'CheckPackageContentOps' operations.------ The point of this extra generality is to allow doing checks in some virtual--- file system, for example a tarball in memory.----checkPackageContent :: (Monad m, Applicative m)-                    => CheckPackageContentOps m-                    -> PackageDescription-                    -> m [PackageCheck]-checkPackageContent ops pkg = do-  cabalBomError   <- checkCabalFileBOM    ops-  cabalNameError  <- checkCabalFileName   ops pkg-  licenseErrors   <- checkLicensesExist   ops pkg-  setupError      <- checkSetupExists     ops pkg-  configureError  <- checkConfigureExists ops pkg-  localPathErrors <- checkLocalPathsExist ops pkg-  vcsLocation     <- checkMissingVcsInfo  ops pkg--  return $ licenseErrors-        ++ catMaybes [cabalBomError, cabalNameError, setupError, configureError]-        ++ localPathErrors-        ++ vcsLocation--checkCabalFileBOM :: Monad m => CheckPackageContentOps m-                  -> m (Maybe PackageCheck)-checkCabalFileBOM ops = do-  epdfile <- findPackageDesc ops-  case epdfile of-    -- MASSIVE HACK.  If the Cabal file doesn't exist, that is-    -- a very strange situation to be in, because the driver code-    -- in 'Distribution.Setup' ought to have noticed already!-    -- But this can be an issue, see #3552 and also when-    -- --cabal-file is specified.  So if you can't find the file,-    -- just don't bother with this check.-    Left _       -> return $ Nothing-    Right pdfile -> (flip check pc . BS.isPrefixOf bomUtf8)-                    `liftM` (getFileContents ops pdfile)-      where pc = PackageDistInexcusable $-                 pdfile ++ " starts with an Unicode byte order mark (BOM)."-                 ++ " This may cause problems with older cabal versions."--  where-    bomUtf8 :: BS.ByteString-    bomUtf8 = BS.pack [0xef,0xbb,0xbf] -- U+FEFF encoded as UTF8--checkCabalFileName :: Monad m => CheckPackageContentOps m-                 -> PackageDescription-                 -> m (Maybe PackageCheck)-checkCabalFileName ops pkg = do-  -- findPackageDesc already takes care to detect missing/multiple-  -- .cabal files; we don't include this check in 'findPackageDesc' in-  -- order not to short-cut other checks which call 'findPackageDesc'-  epdfile <- findPackageDesc ops-  case epdfile of-    -- see "MASSIVE HACK" note in 'checkCabalFileBOM'-    Left _       -> return Nothing-    Right pdfile-      | takeFileName pdfile == expectedCabalname -> return Nothing-      | otherwise -> return $ Just $ PackageDistInexcusable $-                 "The filename " ++ pdfile ++ " does not match package name " ++-                 "(expected: " ++ expectedCabalname ++ ")"-  where-    pkgname = unPackageName . packageName $ pkg-    expectedCabalname = pkgname <.> "cabal"----- |Find a package description file in the given directory.  Looks for--- @.cabal@ files.  Like 'Distribution.Simple.Utils.findPackageDesc',--- but generalized over monads.-findPackageDesc :: Monad m => CheckPackageContentOps m-                 -> m (Either PackageCheck FilePath) -- ^<pkgname>.cabal-findPackageDesc ops- = do let dir = "."-      files <- getDirectoryContents ops dir-      -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal-      -- file we filter to exclude dirs and null base file names:-      cabalFiles <- filterM (doesFileExist ops)-                       [ dir </> file-                       | file <- files-                       , let (name, ext) = splitExtension file-                       , not (null name) && ext == ".cabal" ]-      case cabalFiles of-        []          -> return (Left $ PackageBuildImpossible noDesc)-        [cabalFile] -> return (Right cabalFile)-        multiple    -> return (Left $ PackageBuildImpossible-                               $ multiDesc multiple)--  where-    noDesc :: String-    noDesc = "No cabal file found.\n"-             ++ "Please create a package description file <pkgname>.cabal"--    multiDesc :: [String] -> String-    multiDesc l = "Multiple cabal files found while checking.\n"-                  ++ "Please use only one of: "-                  ++ intercalate ", " l--checkLicensesExist :: (Monad m, Applicative m)-                   => CheckPackageContentOps m-                   -> PackageDescription-                   -> m [PackageCheck]-checkLicensesExist ops pkg = do-    exists <- traverse (doesFileExist ops . getSymbolicPath) (licenseFiles pkg)-    return-      [ PackageBuildWarning $-           "The '" ++ fieldname ++ "' field refers to the file "-        ++ quote (getSymbolicPath file) ++ " which does not exist."-      | (file, False) <- zip (licenseFiles pkg) exists ]-  where-    fieldname | length (licenseFiles pkg) == 1 = "license-file"-              | otherwise                      = "license-files"--checkSetupExists :: Monad m => CheckPackageContentOps m-                 -> PackageDescription-                 -> m (Maybe PackageCheck)-checkSetupExists ops pkg = do-  let simpleBuild = buildType pkg == Simple-  hsexists  <- doesFileExist ops "Setup.hs"-  lhsexists <- doesFileExist ops "Setup.lhs"-  return $ check (not simpleBuild && not hsexists && not lhsexists) $-    PackageDistInexcusable $-      "The package is missing a Setup.hs or Setup.lhs script."--checkConfigureExists :: Monad m => CheckPackageContentOps m-                     -> PackageDescription-                     -> m (Maybe PackageCheck)-checkConfigureExists ops pd-  | buildType pd == Configure = do-      exists <- doesFileExist ops "configure"-      return $ check (not exists) $-        PackageBuildWarning $-          "The 'build-type' is 'Configure' but there is no 'configure' script. "-          ++ "You probably need to run 'autoreconf -i' to generate it."-  | otherwise = return Nothing--checkLocalPathsExist :: Monad m => CheckPackageContentOps m-                     -> PackageDescription-                     -> m [PackageCheck]-checkLocalPathsExist ops pkg = do-  let dirs = [ (dir, kind)-             | bi <- allBuildInfo pkg-             , (dir, kind) <--                  [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ]-               ++ [ (dir, "extra-framework-dirs")-                  | dir <- extraFrameworkDirs  bi ]-               ++ [ (dir, "include-dirs")   | dir <- includeDirs  bi ]-               ++ [ (getSymbolicPath dir, "hs-source-dirs") | dir <- hsSourceDirs bi ]-             , isRelativeOnAnyPlatform dir ]-  missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs-  return [ PackageBuildWarning {-             explanation = quote (kind ++ ": " ++ dir)-                        ++ " directory does not exist."-           }-         | (dir, kind) <- missing ]--checkMissingVcsInfo :: (Monad m, Applicative m)-                    => CheckPackageContentOps m-                    -> PackageDescription-                    -> m [PackageCheck]-checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do-    vcsInUse <- liftM or $ traverse (doesDirectoryExist ops) repoDirnames-    if vcsInUse-      then return [ PackageDistSuspicious message ]-      else return []-  where-    repoDirnames = [ dirname | repo    <- knownRepoTypes-                             , dirname <- repoTypeDirname repo]-    message  = "When distributing packages it is encouraged to specify source "-            ++ "control information in the .cabal file using one or more "-            ++ "'source-repository' sections. See the Cabal user guide for "-            ++ "details."--checkMissingVcsInfo _ _ = return []--repoTypeDirname :: KnownRepoType -> [FilePath]-repoTypeDirname Darcs     = ["_darcs"]-repoTypeDirname Git       = [".git"]-repoTypeDirname SVN       = [".svn"]-repoTypeDirname CVS       = ["CVS"]-repoTypeDirname Mercurial = [".hg"]-repoTypeDirname GnuArch   = [".arch-params"]-repoTypeDirname Bazaar    = [".bzr"]-repoTypeDirname Monotone  = ["_MTN"]-repoTypeDirname Pijul     = [".pijul"]---- --------------------------------------------------------------- * Checks involving files in the package--- ---------------------------------------------------------------- | Check the names of all files in a package for portability problems. This--- should be done for example when creating or validating a package tarball.----checkPackageFileNames :: [FilePath] -> [PackageCheck]-checkPackageFileNames files =-     (take 1 . mapMaybe checkWindowsPath $ files)-  ++ (take 1 . mapMaybe checkTarPath     $ files)-      -- If we get any of these checks triggering then we're likely to get-      -- many, and that's probably not helpful, so return at most one.--checkWindowsPath :: FilePath -> Maybe PackageCheck-checkWindowsPath path =-  check (not $ FilePath.Windows.isValid path') $-    PackageDistInexcusable $-         "Unfortunately, the file " ++ quote path ++ " is not a valid file "-      ++ "name on Windows which would cause portability problems for this "-      ++ "package. Windows file names cannot contain any of the characters "-      ++ "\":*?<>|\" and there are a few reserved names including \"aux\", "-      ++ "\"nul\", \"con\", \"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"."-  where-    path' = ".\\" ++ path-    -- force a relative name to catch invalid file names like "f:oo" which-    -- otherwise parse as file "oo" in the current directory on the 'f' drive.---- | Check a file name is valid for the portable POSIX tar format.------ The POSIX tar format has a restriction on the length of file names. It is--- unfortunately not a simple restriction like a maximum length. The exact--- restriction is that either the whole path be 100 characters or less, or it--- be possible to split the path on a directory separator such that the first--- part is 155 characters or less and the second part 100 characters or less.----checkTarPath :: FilePath -> Maybe PackageCheck-checkTarPath path-  | length path > 255   = Just longPath-  | otherwise = case pack nameMax (reverse (splitPath path)) of-    Left err           -> Just err-    Right []           -> Nothing-    Right (h:rest) -> case pack prefixMax remainder of-      Left err         -> Just err-      Right []         -> Nothing-      Right (_:_)      -> Just noSplit-     where-        -- drop the '/' between the name and prefix:-        remainder = safeInit h : rest--  where-    nameMax, prefixMax :: Int-    nameMax   = 100-    prefixMax = 155--    pack _   []     = Left emptyName-    pack maxLen (c:cs)-      | n > maxLen  = Left longName-      | otherwise   = Right (pack' maxLen n cs)-      where n = length c--    pack' maxLen n (c:cs)-      | n' <= maxLen = pack' maxLen n' cs-      where n' = n + length c-    pack' _     _ cs = cs--    longPath = PackageDistInexcusable $-         "The following file name is too long to store in a portable POSIX "-      ++ "format tar archive. The maximum length is 255 ASCII characters.\n"-      ++ "The file in question is:\n  " ++ path-    longName = PackageDistInexcusable $-         "The following file name is too long to store in a portable POSIX "-      ++ "format tar archive. The maximum length for the name part (including "-      ++ "extension) is 100 ASCII characters. The maximum length for any "-      ++ "individual directory component is 155.\n"-      ++ "The file in question is:\n  " ++ path-    noSplit = PackageDistInexcusable $-         "The following file name is too long to store in a portable POSIX "-      ++ "format tar archive. While the total length is less than 255 ASCII "-      ++ "characters, there are unfortunately further restrictions. It has to "-      ++ "be possible to split the file path on a directory separator into "-      ++ "two parts such that the first part fits in 155 characters or less "-      ++ "and the second part fits in 100 characters or less. Basically you "-      ++ "have to make the file name or directory names shorter, or you could "-      ++ "split a long directory name into nested subdirectories with shorter "-      ++ "names.\nThe file in question is:\n  " ++ path-    emptyName = PackageDistInexcusable $-         "Encountered a file with an empty name, something is very wrong! "-      ++ "Files with an empty name cannot be stored in a tar archive or in "-      ++ "standard file systems."---- ----------------------------------------------------------------- * Checks for missing content and other pre-distribution checks--- ------------------------------------------------------------------ | Similar to 'checkPackageContent', 'checkPackageFilesPreDistribution'--- inspects the files included in the package, but is primarily looking for--- files in the working tree that may have been missed or other similar--- problems that can only be detected pre-distribution.------ Because Hackage necessarily checks the uploaded tarball, it is too late to--- check these on the server; these checks only make sense in the development--- and package-creation environment. Hence we can use IO, rather than needing--- to pass a 'CheckPackageContentOps' dictionary around.-checkPackageFilesPreDistribution :: Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck]--- Note: this really shouldn't return any 'Inexcusable' warnings,--- because that will make us say that Hackage would reject the package.--- But, because Hackage doesn't run these tests, that will be a lie!-checkPackageFilesPreDistribution = checkGlobFiles---- | Discover problems with the package's wildcards.-checkGlobFiles :: Verbosity-               -> PackageDescription-               -> FilePath-               -> IO [PackageCheck]-checkGlobFiles verbosity pkg root =-  fmap concat $ for allGlobs $ \(field, dir, glob) ->-    -- Note: we just skip over parse errors here; they're reported elsewhere.-    case parseFileGlob (specVersion pkg) glob of-      Left _ -> return []-      Right parsedGlob -> do-        results <- runDirFileGlob verbosity (root </> dir) parsedGlob-        let individualWarnings = results >>= getWarning field glob-            noMatchesWarning =-              [ PackageDistSuspiciousWarn $-                     "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not"-                  ++ " match any files."-              | all (not . suppressesNoMatchesWarning) results-              ]-        return (noMatchesWarning ++ individualWarnings)-  where-    adjustedDataDir = if null (dataDir pkg) then "." else dataDir pkg-    allGlobs = concat-      [ (,,) "extra-source-files" "." <$> extraSrcFiles pkg-      , (,,) "extra-doc-files" "." <$> extraDocFiles pkg-      , (,,) "data-files" adjustedDataDir <$> dataFiles pkg-      ]--    -- If there's a missing directory in play, since our globs don't-    -- (currently) support disjunction, that will always mean there are no-    -- matches. The no matches error in this case is strictly less informative-    -- than the missing directory error, so sit on it.-    suppressesNoMatchesWarning (GlobMatch _) = True-    suppressesNoMatchesWarning (GlobWarnMultiDot _) = False-    suppressesNoMatchesWarning (GlobMissingDirectory _) = True--    getWarning :: String -> FilePath -> GlobResult FilePath -> [PackageCheck]-    getWarning _ _ (GlobMatch _) =-      []-    -- Before Cabal 2.4, the extensions of globs had to match the file-    -- exactly. This has been relaxed in 2.4 to allow matching only the-    -- suffix. This warning detects when pre-2.4 package descriptions are-    -- omitting files purely because of the stricter check.-    getWarning field glob (GlobWarnMultiDot file) =-      [ PackageDistSuspiciousWarn $-             "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not"-          ++ " match the file '" ++ file ++ "' because the extensions do not"-          ++ " exactly match (e.g., foo.en.html does not exactly match *.html)."-          ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or higher."-      ]-    getWarning field glob (GlobMissingDirectory dir) =-      [ PackageDistSuspiciousWarn $-             "In '" ++ field ++ "': the pattern '" ++ glob ++ "' attempts to"-          ++ " match files in the directory '" ++ dir ++ "', but there is no"-          ++ " directory by that name."-      ]---- --------------------------------------------------------------- * Utils--- --------------------------------------------------------------quote :: String -> String-quote s = "'" ++ s ++ "'"--commaSep :: [String] -> String-commaSep = intercalate ", "--dups :: Ord a => [a] -> [a]-dups xs = [ x | (x:_:_) <- group (sort xs) ]--fileExtensionSupportedLanguage :: FilePath -> Bool-fileExtensionSupportedLanguage path =-    isHaskell || isC-  where-    extension = takeExtension path-    isHaskell = extension `elem` [".hs", ".lhs"]-    isC       = isJust (filenameCDialect extension)---- | Whether a path is a good relative path.------ >>> let test fp = putStrLn $ show (isGoodRelativeDirectoryPath fp) ++ "; " ++ show (isGoodRelativeFilePath fp)------ >>> test "foo/bar/quu"--- Nothing; Nothing------ Trailing slash is not allowed for files, for directories it is ok.------ >>> test "foo/"--- Nothing; Just "trailing slash"------ Leading @./@ is fine, but @.@ and @./@ are not valid files.------ >>> traverse_ test [".", "./", "./foo/bar"]--- Nothing; Just "trailing dot segment"--- Nothing; Just "trailing slash"--- Nothing; Nothing------ Lastly, not good file nor directory cases:------ >>> traverse_ test ["", "/tmp/src", "foo//bar", "foo/.", "foo/./bar", "foo/../bar", "foo*bar"]--- Just "empty path"; Just "empty path"--- Just "posix absolute path"; Just "posix absolute path"--- Just "empty path segment"; Just "empty path segment"--- Just "trailing same directory segment: ."; Just "trailing same directory segment: ."--- Just "same directory segment: ."; Just "same directory segment: .."--- Just "parent directory segment: .."; Just "parent directory segment: .."--- Just "reserved character '*'"; Just "reserved character '*'"------ For the last case, 'isGoodRelativeGlob' doesn't warn:------ >>> traverse_ (print . isGoodRelativeGlob) ["foo/../bar", "foo*bar"]--- Just "parent directory segment: .."--- Nothing----isGoodRelativeFilePath :: FilePath -> Maybe String-isGoodRelativeFilePath = state0-  where-    -- Reserved characters-    -- https://docs.microsoft.com/en-us/windows/win32/fileio/naming-a-file-    isReserved c = c `elem` "<>:\"\\/|?*"--    -- initial state-    state0 []                    = Just "empty path"-    state0 (c:cs) | c == '.'     = state1 cs-                  | c == '/'     = Just "posix absolute path"-                  | isReserved c = Just ("reserved character " ++ show c)-                  | otherwise    = state3 cs--    -- after .-    state1 []                    = Just "trailing dot segment"-    state1 (c:cs) | c == '.'     = state4 cs-                  | c == '/'     = state2 cs-                  | isReserved c = Just ("reserved character " ++ show c)-                  | otherwise    = state5 cs--    -- after ./-    state2 []                    = Just "trailing slash"-    state2 (c:cs) | c == '.'     = state3 cs-                  | c == '/'     = Just "empty path segment"-                  | isReserved c = Just ("reserved character " ++ show c)-                  | otherwise    = state5 cs--    -- after non-first segment's .-    state3 []                    = Just "trailing same directory segment: ."-    state3 (c:cs) | c == '.'     = state4 cs-                  | c == '/'     = Just "same directory segment: .."-                  | isReserved c = Just ("reserved character " ++ show c)-                  | otherwise    = state5 cs--    -- after non-first segment's ..-    state4 []                    = Just "trailing parent directory segment: .."-    state4 (c:cs) | c == '.'     = state5 cs-                  | c == '/'     = Just "parent directory segment: .."-                  | isReserved c = Just ("reserved character " ++ show c)-                  | otherwise    = state5 cs--    -- in a segment which is ok.-    state5 []                    = Nothing-    state5 (c:cs) | c == '.'     = state3 cs-                  | c == '/'     = state2 cs-                  | isReserved c = Just ("reserved character " ++ show c)-                  | otherwise    = state5 cs---- | See 'isGoodRelativeFilePath'.------ This is barebones function. We check whether the glob is a valid file--- by replacing stars @*@ with @x@ses.-isGoodRelativeGlob :: FilePath -> Maybe String-isGoodRelativeGlob = isGoodRelativeFilePath . map f where-    f '*' = 'x'-    f c   = c---- | See 'isGoodRelativeFilePath'.-isGoodRelativeDirectoryPath :: FilePath -> Maybe String-isGoodRelativeDirectoryPath = state0-  where-    -- Reserved characters-    -- https://docs.microsoft.com/en-us/windows/win32/fileio/naming-a-file-    isReserved c = c `elem` "<>:\"\\/|?*"--    -- initial state-    state0 []                    = Just "empty path"-    state0 (c:cs) | c == '.'     = state5 cs-                  | c == '/'     = Just "posix absolute path"-                  | isReserved c = Just ("reserved character " ++ show c)-                  | otherwise    = state4 cs--    -- after ./-    state1 []                    = Nothing -- "./"-    state1 (c:cs) | c == '.'     = state2 cs-                  | c == '/'     = Just "empty path segment"-                  | isReserved c = Just ("reserved character " ++ show c)-                  | otherwise    = state4 cs--    -- after non-first setgment's .-    state2 []                    = Just "trailing same directory segment: ."-    state2 (c:cs) | c == '.'     = state3 cs-                  | c == '/'     = Just "same directory segment: ."-                  | isReserved c = Just ("reserved character " ++ show c)-                  | otherwise    = state4 cs--    -- after non-first segment's ..-    state3 []                    = Just "trailing parent directory segment: ."-    state3 (c:cs) | c == '.'     = state4 cs-                  | c == '/'     = Just "parent directory segment: .."-                  | isReserved c = Just ("reserved character " ++ show c)-                  | otherwise    = state4 cs--    -- in a segment which is ok.-    state4 []                    = Nothing-    state4 (c:cs) | c == '.'     = state4 cs-                  | c == '/'     = state1 cs-                  | isReserved c = Just ("reserved character " ++ show c)-                  | otherwise    = state4 cs--    -- after .-    state5 []                    = Nothing -- "."-    state5 (c:cs) | c == '.'     = state3 cs-                  | c == '/'     = state1 cs-                  | isReserved c = Just ("reserved character " ++ show c)-                  | otherwise    = state4 cs---- [Note: Good relative paths]------ Using @kleene@ we can define an extended regex:------ @--- import Algebra.Lattice--- import Kleene--- import Kleene.ERE (ERE (..), intersections)------ data C = CDot | CSlash | COtherReserved | CChar---   deriving (Eq, Ord, Enum, Bounded, Show)------ reservedR :: ERE C--- reservedR = notChar CSlash /\ notChar COtherReserved------ pathPieceR :: ERE C--- pathPieceR = intersections---     [ plus reservedR---     , ERENot (string [CDot])---     , ERENot (string [CDot,CDot])---     ]------ filePathR :: ERE C--- filePathR = optional (string [CDot, CSlash]) <> pathPieceR <> star (char CSlash <> pathPieceR)------ dirPathR :: ERE C--- dirPathR = (char CDot \/ filePathR) <> optional (char CSlash)------ plus :: ERE C -> ERE C--- plus r = r <> star r------ optional :: ERE C -> ERE C--- optional r = mempty \/ r--- @------ Results in following state machine for @filePathR@------ @--- 0 -> \x -> if---     | x <= CDot           -> 1---     | x <= COtherReserved -> 6---     | otherwise           -> 5--- 1 -> \x -> if---     | x <= CDot           -> 4---     | x <= CSlash         -> 2---     | x <= COtherReserved -> 6---     | otherwise           -> 5--- 2 -> \x -> if---     | x <= CDot           -> 3---     | x <= COtherReserved -> 6---     | otherwise           -> 5--- 3 -> \x -> if---     | x <= CDot           -> 4---     | x <= COtherReserved -> 6---     | otherwise           -> 5--- 4 -> \x -> if---     | x <= CDot           -> 5---     | x <= COtherReserved -> 6---     | otherwise           -> 5--- 5+ -> \x -> if---     | x <= CDot           -> 5---     | x <= CSlash         -> 2---     | x <= COtherReserved -> 6---     | otherwise           -> 5--- 6 -> \_ -> 6 -- black hole--- @------ and @dirPathR@:------ @--- 0 -> \x -> if---     | x <= CDot           -> 5---     | x <= COtherReserved -> 6---     | otherwise           -> 4--- 1+ -> \x -> if---     | x <= CDot           -> 2---     | x <= COtherReserved -> 6---     | otherwise           -> 4--- 2 -> \x -> if---     | x <= CDot           -> 3---     | x <= COtherReserved -> 6---     | otherwise           -> 4--- 3 -> \x -> if---     | x <= CDot           -> 4---     | x <= COtherReserved -> 6---     | otherwise           -> 4--- 4+ -> \x -> if---     | x <= CDot           -> 4---     | x <= CSlash         -> 1---     | x <= COtherReserved -> 6---     | otherwise           -> 4--- 5+ -> \x -> if---     | x <= CDot           -> 3---     | x <= CSlash         -> 1---     | x <= COtherReserved -> 6---     | otherwise           -> 4--- 6 -> \_ -> 6 -- black hole--- @+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      :  Distribution.PackageDescription.Check+-- Copyright   :  Lennart Kolmodin 2008, Francesco Ariis 2022+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This has code for checking for various problems in packages. There is one+-- set of checks that just looks at a 'PackageDescription' in isolation and+-- another set of checks that also looks at files in the package. Some of the+-- checks are basic sanity checks, others are portability standards that we'd+-- like to encourage. There is a 'PackageCheck' type that distinguishes the+-- different kinds of checks so we can see which ones are appropriate to report+-- in different situations. This code gets used when configuring a package when+-- we consider only basic problems. The higher standard is used when+-- preparing a source tarball and by Hackage when uploading new packages. The+-- reason for this is that we want to hold packages that are expected to be+-- distributed to a higher standard than packages that are only ever expected+-- to be used on the author's own environment.+module Distribution.PackageDescription.Check+  ( -- * Package Checking+    CheckExplanation (..)+  , CheckExplanationID+  , CheckExplanationIDString+  , PackageCheck (..)+  , checkPackage+  , checkConfiguredPackage+  , wrapParseWarning+  , ppPackageCheck+  , ppCheckExplanationId+  , isHackageDistError+  , filterPackageChecksById+  , filterPackageChecksByIdString++    -- ** Checking package contents+  , checkPackageFiles+  , checkPackageFilesGPD+  , checkPackageContent+  , CheckPackageContentOps (..)+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Data.List (group)+import Distribution.CabalSpecVersion+import Distribution.Compat.Lens+import Distribution.Compiler+import Distribution.License+import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Check.Common+import Distribution.PackageDescription.Check.Conditional+import Distribution.PackageDescription.Check.Monad+import Distribution.PackageDescription.Check.Paths+import Distribution.PackageDescription.Check.Target+import Distribution.PackageDescription.Check.Warning+import Distribution.Parsec.Warning (PWarning)+import Distribution.Pretty (prettyShow)+import Distribution.Simple.Glob+  ( Glob+  , GlobResult (..)+  , globMatches+  , parseFileGlob+  , runDirFileGlob+  )+import Distribution.Simple.Utils hiding (findPackageDesc, notice)+import Distribution.Utils.Generic (isAscii)+import Distribution.Utils.Path+import Distribution.Verbosity+import Distribution.Version+import System.FilePath (splitExtension, takeFileName)++import qualified Data.ByteString.Lazy as BS+import qualified Distribution.SPDX as SPDX+import qualified System.Directory as System++import qualified System.Directory (getDirectoryContents)+import qualified System.FilePath.Windows as FilePath.Windows (isValid)++import qualified Data.Set as Set+import qualified Distribution.Utils.ShortText as ShortText++import qualified Distribution.Types.GenericPackageDescription.Lens as L++import Control.Monad++-- $setup+-- >>> import Control.Arrow ((&&&))++-- ☞ N.B.+--+-- Part of the tools/scaffold used to perform check is found in+-- Distribution.PackageDescription.Check.Types. Summary of that module (for+-- how we use it here):+-- 1. we work inside a 'CheckM m a' monad (where `m` is an abstraction to+--    run non-pure checks);+-- 2. 'checkP', 'checkPre' functions perform checks (respectively pure and+--    non-pure);+-- 3. 'PackageCheck' and 'CheckExplanation' are types for warning severity+--    and description.++-- ------------------------------------------------------------+-- Checking interface+-- ------------------------------------------------------------++-- | 'checkPackagePrim' is the most general way to invoke package checks.+-- We pass to it two interfaces (one to check contents of packages, the+-- other to inspect working tree for orphan files) and before that a+-- Boolean to indicate whether we want pure checks or not. Based on these+-- parameters, some checks will be performed, some omitted.+-- Generality over @m@ means we could do non pure checks in monads other+-- than IO (e.g. a virtual filesystem, like a zip file, a VCS filesystem,+-- etc).+checkPackagePrim+  :: Monad m+  => Bool -- Perform pure checks?+  -> Maybe (CheckPackageContentOps m) -- Package content interface.+  -> Maybe (CheckPreDistributionOps m) -- Predist checks interface.+  -> GenericPackageDescription -- GPD to check.+  -> m [PackageCheck]+checkPackagePrim b mco mpdo gpd = do+  let cm = checkGenericPackageDescription gpd+      ci = CheckInterface b mco mpdo+      ctx = pristineCheckCtx ci gpd+  execCheckM cm ctx++-- | Check for common mistakes and problems in package descriptions.+--+-- This is the standard collection of checks covering all aspects except+-- for checks that require looking at files within the package. For those+-- see 'checkPackageFiles'.+checkPackage :: GenericPackageDescription -> [PackageCheck]+checkPackage gpd = runIdentity $ checkPackagePrim True Nothing Nothing gpd++-- | This function is an oddity due to the historical+-- GenericPackageDescription/PackageDescription split. It is only maintained+-- not to break interface, use `checkPackage` if possible.+checkConfiguredPackage :: PackageDescription -> [PackageCheck]+checkConfiguredPackage pd = checkPackage (pd2gpd pd)++-- | Sanity check things that requires looking at files in the package.+-- This is a generalised version of 'checkPackageFiles' that can work in any+-- monad for which you can provide 'CheckPackageContentOps' operations.+--+-- The point of this extra generality is to allow doing checks in some virtual+-- file system, for example a tarball in memory.+checkPackageContent+  :: Monad m+  => CheckPackageContentOps m+  -> GenericPackageDescription+  -> m [PackageCheck]+checkPackageContent pops gpd = checkPackagePrim False (Just pops) Nothing gpd++-- | Sanity checks that require IO. 'checkPackageFiles' looks at the files+-- in the package and expects to find the package unpacked at the given+-- filepath.+checkPackageFilesGPD+  :: Verbosity -- Glob warn message verbosity.+  -> GenericPackageDescription+  -> FilePath -- Package root.+  -> IO [PackageCheck]+checkPackageFilesGPD verbosity gpd root =+  checkPackagePrim False (Just checkFilesIO) (Just checkPreIO) gpd+  where+    checkFilesIO =+      CheckPackageContentOps+        { doesFileExist = System.doesFileExist . relative+        , doesDirectoryExist = System.doesDirectoryExist . relative+        , getDirectoryContents = System.Directory.getDirectoryContents . relative+        , getFileContents = BS.readFile . relative+        }++    checkPreIO =+      CheckPreDistributionOps+        { runDirFileGlobM = \fp g -> runDirFileGlob verbosity (Just . specVersion $ packageDescription gpd) (root </> fp) g+        , getDirectoryContentsM = System.Directory.getDirectoryContents . relative+        }++    relative :: FilePath -> FilePath+    relative path = root </> path++-- | Same as  'checkPackageFilesGPD', but working with 'PackageDescription'.+--+-- This function is included for legacy reasons, use 'checkPackageFilesGPD'+-- if you are working with 'GenericPackageDescription'.+checkPackageFiles+  :: Verbosity -- Glob warn message verbosity.+  -> PackageDescription+  -> FilePath -- Package root.+  -> IO [PackageCheck]+checkPackageFiles verbosity pd oot =+  checkPackageFilesGPD verbosity (pd2gpd pd) oot++-- ------------------------------------------------------------+-- Package description+-- ------------------------------------------------------------++-- Here lies the meat of the module. Starting from 'GenericPackageDescription',+-- we walk the data while doing a number of checks.+--+-- Where applicable we do a full pattern match (if the data changes, code will+-- break: a gentle reminder to add more checks).+-- Pattern matching variables convention: matching accessor + underscore.+-- This way it is easier to see which one we are missing if we run into+-- an “GPD should have 20 arguments but has been given only 19” error.++-- | 'GenericPackageDescription' checks. Remember that for historical quirks+-- in the cabal codebase we have both `GenericPackageDescription` and+-- `PackageDescription` and that PD is both a *field* of GPD and a concept+-- of its own (i.e. a fully realised GPD).+-- In this case we are checking (correctly) GPD, so for target info/checks+-- you should walk condLibrary_ etc. and *not* the (empty) target info in+-- PD. See 'pd2gpd' for a convenient hack when you only have+-- 'PackageDescription'.+checkGenericPackageDescription+  :: Monad m+  => GenericPackageDescription+  -> CheckM m ()+checkGenericPackageDescription+  gpd@( GenericPackageDescription+          packageDescription_+          _gpdScannedVersion_+          genPackageFlags_+          condLibrary_+          condSubLibraries_+          condForeignLibs_+          condExecutables_+          condTestSuites_+          condBenchmarks_+        ) =+    do+      -- § Description and names.+      checkPackageDescription packageDescription_+      -- Targets should be present...+      let condAllLibraries =+            maybeToList condLibrary_+              ++ (map snd condSubLibraries_)+      checkP+        ( and+            [ null condExecutables_+            , null condTestSuites_+            , null condBenchmarks_+            , null condAllLibraries+            , null condForeignLibs_+            ]+        )+        (PackageBuildImpossible NoTarget)+      -- ... and have unique names (names are not under conditional, it is+      -- appropriate to check here.+      (nsubs, nexes, ntests, nbenchs) <-+        asksCM+          ( ( \n ->+                ( pnSubLibs n+                , pnExecs n+                , pnTests n+                , pnBenchs n+                )+            )+              . ccNames+          )+      let names = concat [nsubs, nexes, ntests, nbenchs]+          dupes = dups names+      checkP+        (not . null $ dups names)+        (PackageBuildImpossible $ DuplicateSections dupes)+      -- Flag names.+      mapM_ checkFlagName genPackageFlags_++      -- § Feature checks.+      checkSpecVer+        CabalSpecV2_0+        (not . null $ condSubLibraries_)+        (PackageDistInexcusable CVMultiLib)+      checkSpecVer+        CabalSpecV1_8+        (not . null $ condTestSuites_)+        (PackageDistInexcusable CVTestSuite)++      -- § Conditional targets++      -- Extract dependencies from libraries, to be passed along for+      -- PVP checks purposes.+      pName <-+        asksCM+          ( packageNameToUnqualComponentName+              . pkgName+              . pnPackageId+              . ccNames+          )+      let ads =+            maybe [] ((: []) . extractAssocDeps pName) condLibrary_+              ++ map (uncurry extractAssocDeps) condSubLibraries_++      case condLibrary_ of+        Just cl ->+          checkCondTarget+            genPackageFlags_+            (checkLibrary False ads)+            (const id)+            (mempty, cl)+        Nothing -> return ()+      mapM_+        ( checkCondTarget+            genPackageFlags_+            (checkLibrary False ads)+            (\u l -> l{libName = maybeToLibraryName (Just u)})+        )+        condSubLibraries_+      mapM_+        ( checkCondTarget+            genPackageFlags_+            checkForeignLib+            (const id)+        )+        condForeignLibs_+      mapM_+        ( checkCondTarget+            genPackageFlags_+            (checkExecutable ads)+            (const id)+        )+        condExecutables_+      mapM_+        ( checkCondTarget+            genPackageFlags_+            (checkTestSuite ads)+            (\u l -> l{testName = u})+        )+        condTestSuites_+      mapM_+        ( checkCondTarget+            genPackageFlags_+            (checkBenchmark ads)+            (\u l -> l{benchmarkName = u})+        )+        condBenchmarks_++      -- For unused flags it is clearer and more convenient to fold the+      -- data rather than walk it, an exception to the rule.+      checkP+        (decFlags /= usedFlags)+        (PackageDistSuspicious $ DeclaredUsedFlags decFlags usedFlags)++      -- Duplicate modules.+      mapM_ tellP (checkDuplicateModules gpd)+    where+      -- todo is this caught at parse time?+      checkFlagName :: Monad m => PackageFlag -> CheckM m ()+      checkFlagName pf =+        let fn = unFlagName . flagName $ pf++            invalidFlagName ('-' : _) = True -- starts with dash+            invalidFlagName cs = any (not . isAscii) cs -- non ASCII+         in checkP+              (invalidFlagName fn)+              (PackageDistInexcusable $ SuspiciousFlagName [fn])++      decFlags :: Set.Set FlagName+      decFlags = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd++      usedFlags :: Set.Set FlagName+      usedFlags =+        mconcat+          [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd+          , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd+          , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd+          , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd+          , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd+          , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd+          ]++checkPackageDescription :: Monad m => PackageDescription -> CheckM m ()+checkPackageDescription+  pkg@( PackageDescription+          specVersion_+          package_+          licenseRaw_+          licenseFiles_+          _copyright_+          maintainer_+          _author_+          _stability_+          testedWith_+          _homepage_+          _pkgUrl_+          _bugReports_+          sourceRepos_+          synopsis_+          description_+          category_+          customFieldsPD_+          buildTypeRaw_+          setupBuildInfo_+          _library_+          _subLibraries_+          _executables_+          _foreignLibs_+          _testSuites_+          _benchmarks_+          dataFiles_+          dataDir_+          extraSrcFiles_+          extraTmpFiles_+          extraDocFiles_+          extraFiles_+        ) = do+    -- § Sanity checks.+    checkPackageId package_+    -- TODO `name` is caught at parse level, remove this test.+    let pn = packageName package_+    checkP+      (null . unPackageName $ pn)+      (PackageBuildImpossible NoNameField)+    -- TODO `version` is caught at parse level, remove this test.+    checkP+      (nullVersion == packageVersion package_)+      (PackageBuildImpossible NoVersionField)+    -- But it is OK for executables to have the same name.+    nsubs <- asksCM (pnSubLibs . ccNames)+    checkP+      (any (== prettyShow pn) (prettyShow <$> nsubs))+      (PackageBuildImpossible $ IllegalLibraryName pn)++    -- § Fields check.+    checkNull+      category_+      (PackageDistSuspicious MissingFieldCategory)+    checkNull+      maintainer_+      (PackageDistSuspicious MissingFieldMaintainer)+    checkP+      (ShortText.null synopsis_ && not (ShortText.null description_))+      (PackageDistSuspicious MissingFieldSynopsis)+    checkP+      (ShortText.null description_ && not (ShortText.null synopsis_))+      (PackageDistSuspicious MissingFieldDescription)+    checkP+      (all ShortText.null [synopsis_, description_])+      (PackageDistInexcusable MissingFieldSynOrDesc)+    checkP+      (ShortText.length synopsis_ > 80)+      (PackageDistSuspicious SynopsisTooLong)+    checkP+      ( not (ShortText.null description_)+          && ShortText.length description_ <= ShortText.length synopsis_+      )+      (PackageDistSuspicious ShortDesc)++    -- § Paths.+    mapM_ (checkPath False "extra-source-files" PathKindGlob . getSymbolicPath) extraSrcFiles_+    mapM_ (checkPath False "extra-tmp-files" PathKindFile . getSymbolicPath) extraTmpFiles_+    mapM_ (checkPath False "extra-doc-files" PathKindGlob . getSymbolicPath) extraDocFiles_+    mapM_ (checkPath False "extra-files" PathKindGlob . getSymbolicPath) extraFiles_+    mapM_ (checkPath False "data-files" PathKindGlob . getSymbolicPath) dataFiles_+    let rawDataDir = getSymbolicPath dataDir_+    checkPath True "data-dir" PathKindDirectory rawDataDir+    let licPaths = map getSymbolicPath licenseFiles_+    mapM_ (checkPath False "license-file" PathKindFile) licPaths+    mapM_ checkLicFileExist licenseFiles_++    -- § Globs.+    dataGlobs <- mapM (checkGlob "data-files" . getSymbolicPath) dataFiles_+    extraSrcGlobs <- mapM (checkGlob "extra-source-files" . getSymbolicPath) extraSrcFiles_+    docGlobs <- mapM (checkGlob "extra-doc-files" . getSymbolicPath) extraDocFiles_+    extraGlobs <- mapM (checkGlob "extra-files" . getSymbolicPath) extraFiles_+    -- We collect globs to feed them to checkMissingDocs.++    -- § Missing documentation.+    checkMissingDocs+      (catMaybes dataGlobs)+      (catMaybes extraSrcGlobs)+      (catMaybes docGlobs)+      (catMaybes extraGlobs)++    -- § Datafield checks.+    checkSetupBuildInfo setupBuildInfo_+    mapM_ checkTestedWith testedWith_+    either+      checkNewLicense+      (checkOldLicense $ null licenseFiles_)+      licenseRaw_+    checkSourceRepos sourceRepos_+    mapM_ checkCustomField customFieldsPD_++    -- Feature checks.+    checkSpecVer+      CabalSpecV1_18+      (not . null $ extraDocFiles_)+      (PackageDistInexcusable CVExtraDocFiles)+    checkSpecVer+      CabalSpecV1_6+      (not . null $ sourceRepos_)+      (PackageDistInexcusable CVSourceRepository)+    checkP+      ( specVersion_ >= CabalSpecV1_24+          && isNothing setupBuildInfo_+          && buildTypeRaw_ == Just Custom+      )+      (PackageBuildWarning CVCustomSetup)+    checkSpecVer+      CabalSpecV1_24+      ( isNothing setupBuildInfo_+          && buildTypeRaw_ == Just Custom+      )+      (PackageDistSuspiciousWarn CVExpliticDepsCustomSetup)+    checkP+      (isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2)+      (PackageBuildWarning NoBuildType)+    checkP+      (isJust setupBuildInfo_ && buildType pkg `notElem` [Custom, Hooks])+      (PackageBuildWarning NoCustomSetup)++    -- Contents.+    checkConfigureExists (buildType pkg)+    checkSetupExists (buildType pkg)+    checkCabalFile (packageName pkg)+    mapM_ (checkGlobFile specVersion_ "." "extra-source-files" . getSymbolicPath) extraSrcFiles_+    mapM_ (checkGlobFile specVersion_ "." "extra-doc-files" . getSymbolicPath) extraDocFiles_+    mapM_ (checkGlobFile specVersion_ "." "extra-files" . getSymbolicPath) extraFiles_+    mapM_ (checkGlobFile specVersion_ rawDataDir "data-files" . getSymbolicPath) dataFiles_+    where+      checkNull+        :: Monad m+        => ShortText.ShortText+        -> PackageCheck+        -> CheckM m ()+      checkNull st c = checkP (ShortText.null st) c++      checkTestedWith+        :: Monad m+        => (CompilerFlavor, VersionRange)+        -> CheckM m ()+      checkTestedWith (OtherCompiler n, _) =+        tellP (PackageBuildWarning $ UnknownCompilers [n])+      checkTestedWith (compiler, versionRange) =+        checkVersionRange compiler versionRange++      checkVersionRange+        :: Monad m+        => CompilerFlavor+        -> VersionRange+        -> CheckM m ()+      checkVersionRange cmp vr =+        when+          (isNoVersion vr)+          ( let dep =+                  [ Dependency+                      (mkPackageName (prettyShow cmp))+                      vr+                      mainLibSet+                  ]+             in tellP (PackageDistInexcusable (InvalidTestWith dep))+          )++checkSetupBuildInfo :: Monad m => Maybe SetupBuildInfo -> CheckM m ()+checkSetupBuildInfo Nothing = return ()+checkSetupBuildInfo (Just (SetupBuildInfo ds _)) = do+  let uqs = map mkUnqualComponentName ["base", "Cabal"]+  (is, rs) <- partitionDeps [] uqs ds+  let ick = PackageDistInexcusable . UpperBoundSetup+      rck =+        PackageDistSuspiciousWarn+          . MissingUpperBounds CETSetup+      leuck =+        PackageDistSuspiciousWarn+          . LEUpperBounds CETSetup+      tzuck =+        PackageDistSuspiciousWarn+          . TrailingZeroUpperBounds CETSetup+      gtlck =+        PackageDistSuspiciousWarn+          . GTLowerBounds CETSetup+  checkPVP (checkDependencyVersionRange $ not . hasUpperBound) ick is+  checkPVPs (checkDependencyVersionRange $ not . hasUpperBound) rck rs+  checkPVPs (checkDependencyVersionRange hasLEUpperBound) leuck ds+  checkPVPs (checkDependencyVersionRange hasTrailingZeroUpperBound) tzuck ds+  checkPVPs (checkDependencyVersionRange hasGTLowerBound) gtlck ds++checkPackageId :: Monad m => PackageIdentifier -> CheckM m ()+checkPackageId (PackageIdentifier pkgName_ _pkgVersion_) = do+  checkP+    (not . FilePath.Windows.isValid . prettyShow $ pkgName_)+    (PackageDistInexcusable $ InvalidNameWin pkgName_)+  checkP (isPrefixOf "z-" . prettyShow $ pkgName_) $+    (PackageDistInexcusable ZPrefix)++checkNewLicense :: Monad m => SPDX.License -> CheckM m ()+checkNewLicense lic = do+  checkP+    (lic == SPDX.NONE)+    (PackageDistInexcusable NONELicense)++checkOldLicense+  :: Monad m+  => Bool -- Flag: no license file?+  -> License+  -> CheckM m ()+checkOldLicense nullLicFiles lic = do+  checkP+    (lic == UnspecifiedLicense)+    (PackageDistInexcusable NoLicense)+  checkP+    (lic == AllRightsReserved)+    (PackageDistSuspicious AllRightsReservedLicense)+  checkSpecVer+    CabalSpecV1_4+    (lic `notElem` compatLicenses)+    (PackageDistInexcusable (LicenseMessParse lic))+  checkP+    (lic == BSD4)+    (PackageDistSuspicious UncommonBSD4)+  case lic of+    UnknownLicense l ->+      tellP (PackageBuildWarning (UnrecognisedLicense l))+    _ -> return ()+  checkP+    ( lic+        `notElem` [ AllRightsReserved+                  , UnspecifiedLicense+                  , PublicDomain+                  ]+        &&+        -- AllRightsReserved and PublicDomain are not strictly+        -- licenses so don't need license files.+        nullLicFiles+    )+    $ (PackageDistSuspicious NoLicenseFile)+  case unknownLicenseVersion lic of+    Just knownVersions ->+      tellP+        (PackageDistSuspicious $ UnknownLicenseVersion lic knownVersions)+    _ -> return ()+  where+    compatLicenses =+      [ GPL Nothing+      , LGPL Nothing+      , AGPL Nothing+      , BSD3+      , BSD4+      , PublicDomain+      , AllRightsReserved+      , UnspecifiedLicense+      , OtherLicense+      ]++    unknownLicenseVersion (GPL (Just v))+      | v `notElem` knownVersions = Just knownVersions+      where+        knownVersions = [v' | GPL (Just v') <- knownLicenses]+    unknownLicenseVersion (LGPL (Just v))+      | v `notElem` knownVersions = Just knownVersions+      where+        knownVersions = [v' | LGPL (Just v') <- knownLicenses]+    unknownLicenseVersion (AGPL (Just v))+      | v `notElem` knownVersions = Just knownVersions+      where+        knownVersions = [v' | AGPL (Just v') <- knownLicenses]+    unknownLicenseVersion (Apache (Just v))+      | v `notElem` knownVersions = Just knownVersions+      where+        knownVersions = [v' | Apache (Just v') <- knownLicenses]+    unknownLicenseVersion _ = Nothing++checkSourceRepos :: Monad m => [SourceRepo] -> CheckM m ()+checkSourceRepos rs = do+  mapM_ repoCheck rs+  checkMissingVcsInfo rs+  where+    -- Single repository checks.+    repoCheck :: Monad m => SourceRepo -> CheckM m ()+    repoCheck+      ( SourceRepo+          repoKind_+          repoType_+          repoLocation_+          repoModule_+          _repoBranch_+          repoTag_+          repoSubdir_+        ) = do+        case repoKind_ of+          RepoKindUnknown kind ->+            tellP+              (PackageDistInexcusable $ UnrecognisedSourceRepo kind)+          _ -> return ()+        checkP+          (isNothing repoType_)+          (PackageDistInexcusable MissingType)+        checkP+          (isNothing repoLocation_)+          (PackageDistInexcusable MissingLocation)+        checkGitProtocol repoLocation_+        checkP+          ( repoType_ == Just (KnownRepoType CVS)+              && isNothing repoModule_+          )+          (PackageDistInexcusable MissingModule)+        checkP+          (repoKind_ == RepoThis && isNothing repoTag_)+          (PackageDistInexcusable MissingTag)+        checkP+          (any isAbsoluteOnAnyPlatform repoSubdir_)+          (PackageDistInexcusable SubdirRelPath)+        case join . fmap isGoodRelativeDirectoryPath $ repoSubdir_ of+          Just err ->+            tellP+              (PackageDistInexcusable $ SubdirGoodRelPath err)+          Nothing -> return ()++checkMissingVcsInfo :: Monad m => [SourceRepo] -> CheckM m ()+checkMissingVcsInfo rs =+  let rdirs = concatMap repoTypeDirname knownRepoTypes+   in checkPkg+        ( \ops -> do+            us <- or <$> traverse (doesDirectoryExist ops) rdirs+            return (null rs && us)+        )+        (PackageDistSuspicious MissingSourceControl)+  where+    repoTypeDirname :: KnownRepoType -> [FilePath]+    repoTypeDirname Darcs = ["_darcs"]+    repoTypeDirname Git = [".git"]+    repoTypeDirname SVN = [".svn"]+    repoTypeDirname CVS = ["CVS"]+    repoTypeDirname Mercurial = [".hg"]+    repoTypeDirname GnuArch = [".arch-params"]+    repoTypeDirname Bazaar = [".bzr"]+    repoTypeDirname Monotone = ["_MTN"]+    repoTypeDirname Pijul = [".pijul"]++-- git:// lacks TLS or other encryption, see+-- https://git-scm.com/book/en/v2/Git-on-the-Server-The-Protocols#_the_cons_4+checkGitProtocol+  :: Monad m+  => Maybe String -- Repository location+  -> CheckM m ()+checkGitProtocol mloc =+  checkP+    (fmap (isPrefixOf "git://") mloc == Just True)+    (PackageBuildWarning GitProtocol)++-- ------------------------------------------------------------+-- Package and distribution checks+-- ------------------------------------------------------------++-- | Find a package description file in the given directory.  Looks for+-- @.cabal@ files.  Like 'Distribution.Simple.Utils.findPackageDesc',+-- but generalized over monads.+findPackageDesc :: Monad m => CheckPackageContentOps m -> m [FilePath]+findPackageDesc ops = do+  let dir = "."+  files <- getDirectoryContents 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 <-+    filterM+      (doesFileExist ops)+      [ dir </> file+      | file <- files+      , let (name, ext) = splitExtension file+      , not (null name) && ext == ".cabal"+      ]+  return cabalFiles++checkCabalFile :: Monad m => PackageName -> CheckM m ()+checkCabalFile pn = do+  -- liftInt is a bit more messy than stricter interface, but since+  -- each of the following check is exclusive, we can simplify the+  -- condition flow.+  liftInt+    ciPackageOps+    ( \ops -> do+        -- 1. Get .cabal files.+        ds <- findPackageDesc ops+        case ds of+          [] -> return [PackageBuildImpossible NoDesc]+          -- No .cabal file.+          [d] -> do+            bc <- bomf ops d+            return (catMaybes [bc, noMatch d])+          -- BOM + no matching .cabal checks.+          _ -> return [PackageBuildImpossible $ MultiDesc ds]+    )+  where+    -- Multiple .cabal files.++    bomf+      :: Monad m+      => CheckPackageContentOps m+      -> FilePath+      -> m (Maybe PackageCheck)+    bomf wops wfp = do+      b <- BS.isPrefixOf bomUtf8 <$> getFileContents wops wfp+      if b+        then (return . Just) (PackageDistInexcusable $ BOMStart wfp)+        else return Nothing++    bomUtf8 :: BS.ByteString+    bomUtf8 = BS.pack [0xef, 0xbb, 0xbf] -- U+FEFF encoded as UTF8+    noMatch :: FilePath -> Maybe PackageCheck+    noMatch wd =+      let expd = unPackageName pn <.> "cabal"+       in if takeFileName wd /= expd+            then Just (PackageDistInexcusable $ NotPackageName wd expd)+            else Nothing++checkLicFileExist+  :: Monad m+  => RelativePath Pkg File+  -> CheckM m ()+checkLicFileExist sp = do+  let fp = getSymbolicPath sp+  checkPkg+    (\ops -> not <$> doesFileExist ops fp)+    (PackageBuildWarning $ UnknownFile "license-file" sp)++checkConfigureExists :: Monad m => BuildType -> CheckM m ()+checkConfigureExists Configure =+  checkPkg+    (\ops -> not <$> doesFileExist ops "configure")+    (PackageBuildWarning MissingConfigureScript)+checkConfigureExists _ = return ()++checkSetupExists :: Monad m => BuildType -> CheckM m ()+checkSetupExists Simple = return ()+checkSetupExists _ =+  checkPkg+    ( \ops -> do+        ba <- doesFileExist ops "Setup.hs"+        bb <- doesFileExist ops "Setup.lhs"+        return (not $ ba || bb)+    )+    (PackageDistInexcusable MissingSetupFile)++-- The following functions are similar to 'CheckPackageContentOps m' ones,+-- but, as they inspect the files included in the package, but are primarily+-- looking for files in the working tree that may have been missed or other+-- similar problems that can only be detected pre-distribution.+--+-- Because Hackage necessarily checks the uploaded tarball, it is too late to+-- check these on the server; these checks only make sense in the development+-- and package-creation environment.+-- This most likely means we need to use IO, but a dictionary+-- 'CheckPreDistributionOps m' is provided in case in the future such+-- information can come from somewhere else (e.g. VCS filesystem).+--+-- Note: this really shouldn't return any 'Inexcusable' warnings,+-- because that will make us say that Hackage would reject the package.+-- But, because Hackage doesn't yet run these tests, that will be a lie!++checkGlobFile+  :: Monad m+  => CabalSpecVersion+  -> FilePath -- Glob pattern.+  -> FilePath -- Folder to check.+  -> CabalField -- .cabal field we are checking.+  -> CheckM m ()+checkGlobFile cv ddir title fp = do+  let adjDdir = if null ddir then "." else ddir+      dir+        | title == "data-files" = adjDdir+        | otherwise = "."++  case parseFileGlob cv fp of+    -- We just skip over parse errors here; they're reported elsewhere.+    Left _ -> return ()+    Right parsedGlob -> do+      liftInt ciPreDistOps $ \po -> do+        rs <- runDirFileGlobM po dir parsedGlob+        return $ checkGlobResult title fp rs++-- | Checks for matchless globs and too strict matching (<2.4 spec).+checkGlobResult+  :: CabalField -- .cabal field we are checking+  -> FilePath -- Glob pattern (to show the user+  -- which pattern is the offending+  -- one).+  -> [GlobResult FilePath] -- List of glob results.+  -> [PackageCheck]+checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs)+  where+    dirCheck+      | all (not . withoutNoMatchesWarning) rs =+          [PackageDistSuspiciousWarn $ GlobNoMatch title fp]+      | otherwise = []++    -- If there's a missing directory in play, since globs in Cabal packages+    -- don't (currently) support disjunction, that will always mean there are+    -- no matches. The no matches error in this case is strictly less+    -- informative than the missing directory error.+    withoutNoMatchesWarning (GlobMatch _) = True+    withoutNoMatchesWarning (GlobWarnMultiDot _) = False+    withoutNoMatchesWarning (GlobMissingDirectory _) = True+    withoutNoMatchesWarning (GlobMatchesDirectory _) = True++    getWarning :: GlobResult FilePath -> Maybe PackageCheck+    getWarning (GlobMatch _) = Nothing+    -- Before Cabal 2.4, the extensions of globs had to match the file+    -- exactly. This has been relaxed in 2.4 to allow matching only the+    -- suffix. This warning detects when pre-2.4 package descriptions+    -- are omitting files purely because of the stricter check.+    getWarning (GlobWarnMultiDot file) =+      Just $ PackageDistSuspiciousWarn (GlobExactMatch title fp file)+    getWarning (GlobMissingDirectory dir) =+      Just $ PackageDistSuspiciousWarn (GlobNoDir title fp dir)+    -- GlobMatchesDirectory is handled elsewhere if relevant;+    -- we can discard it here.+    getWarning (GlobMatchesDirectory _) = Nothing++-- ------------------------------------------------------------+-- Other exports+-- ------------------------------------------------------------++-- | Wraps `ParseWarning` into `PackageCheck`.+wrapParseWarning :: FilePath -> PWarning -> PackageCheck+wrapParseWarning fp pw = PackageDistSuspicious (ParseWarning fp pw)++-- TODO: as Jul 2022 there is no severity indication attached PWarnType.+--       Once that is added, we can output something more appropriate+--       than PackageDistSuspicious for every parse warning.+--       (see: Cabal-syntax/src/Distribution/Parsec/Warning.hs)++-- ------------------------------------------------------------+-- Ancillaries+-- ------------------------------------------------------------++-- Gets a list of dependencies from a Library target to pass to PVP related+-- functions. We are not doing checks here: this is not imprecise, as the+-- library itself *will* be checked for PVP errors.+-- Same for branch merging,+-- each of those branch will be checked one by one.+extractAssocDeps+  :: UnqualComponentName -- Name of the target library+  -> CondTree ConfVar [Dependency] 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)++-- | August 2022: this function is an oddity due to the historical+-- GenericPackageDescription/PackageDescription split (check+-- Distribution.Types.PackageDescription for a description of the relationship+-- between GPD and PD.+-- It is only maintained not to break interface, should be deprecated in the+-- future in favour of `checkPackage` when PD and GPD are refactored sensibly.+pd2gpd :: PackageDescription -> GenericPackageDescription+pd2gpd pd = gpd+  where+    gpd :: GenericPackageDescription+    gpd =+      emptyGenericPackageDescription+        { packageDescription = pd+        , condLibrary = fmap t2c (library pd)+        , condSubLibraries = map (t2cName ln id) (subLibraries pd)+        , condForeignLibs =+            map+              (t2cName foreignLibName id)+              (foreignLibs pd)+        , condExecutables =+            map+              (t2cName exeName id)+              (executables pd)+        , condTestSuites =+            map+              (t2cName testName remTest)+              (testSuites pd)+        , condBenchmarks =+            map+              (t2cName benchmarkName remBench)+              (benchmarks pd)+        }++    -- From target to simple, unconditional CondTree.+    t2c :: a -> CondTree ConfVar [Dependency] 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+    -- the target. This is needed for 'initTargetAnnotation' to work+    -- properly and to contain all the quirks inside 'pd2gpd'.+    t2cName+      :: (a -> UnqualComponentName)+      -> (a -> a)+      -> a+      -> (UnqualComponentName, CondTree ConfVar [Dependency] a)+    t2cName nf mf a = (nf a, t2c . mf $ a)++    ln :: Library -> UnqualComponentName+    ln wl = case libName wl of+      (LSubLibName u) -> u+      LMainLibName -> mkUnqualComponentName "main-library"++    remTest :: TestSuite -> TestSuite+    remTest t = t{testName = mempty}++    remBench :: Benchmark -> Benchmark+    remBench b = b{benchmarkName = mempty}++-- checkMissingDocs will check that we don’t have an interesting file+-- (changes.txt, Changelog.md, NEWS, etc.) in our work-tree which is not+-- present in our .cabal file.+checkMissingDocs+  :: Monad m+  => [Glob] -- data-files globs.+  -> [Glob] -- extra-source-files globs.+  -> [Glob] -- extra-doc-files globs.+  -> [Glob] -- extra-files globs.+  -> CheckM m ()+checkMissingDocs dgs esgs edgs efgs = do+  extraDocSupport <- (>= CabalSpecV1_18) <$> asksCM ccSpecVersion++  -- Everything in this block uses CheckPreDistributionOps interface.+  liftInt+    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.+        let des = filter isDesirableExtraDocFile rootContents++        -- 2. Realise Globs.+        let realGlob t =+              concatMap globMatches+                <$> mapM (runDirFileGlobM ops "") t+        rgs <- realGlob dgs+        res <- realGlob esgs+        red <- realGlob edgs+        ref <- realGlob efgs++        -- 3. Check if anything in 1. is missing in 2.+        let mcs = checkDoc extraDocSupport des (rgs ++ res ++ red ++ ref)++        -- 4. Check if files are present but in the wrong field.+        let pcsData = checkDocMove extraDocSupport "data-files" des rgs+            pcsSource =+              if extraDocSupport+                then+                  checkDocMove+                    extraDocSupport+                    "extra-source-files"+                    des+                    res+                else []+            pcs = pcsData ++ pcsSource++        return (mcs ++ pcs)+    )+  where+    checkDoc+      :: Bool -- Cabal spec ≥ 1.18?+      -> [FilePath] -- Desirables.+      -> [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+              ]++    checkDocMove+      :: Bool -- Cabal spec ≥ 1.18?+      -> CabalField -- Name of the field.+      -> [FilePath] -- Desirables.+      -> [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+              ]++-- Predicate for desirable documentation file on Hackage server.+isDesirableExtraDocFile :: FilePath -> Bool+isDesirableExtraDocFile path =+  basename `elem` desirableChangeLog+    && ext `elem` desirableChangeLogExtensions+  where+    (basename, ext) = splitExtension (map toLower path)++    -- Changelog patterns (basenames & extensions)+    -- Source: hackage-server/src/Distribution/Server/Packages/ChangeLog.hs+    desirableChangeLog = ["news", "changelog", "change_log", "changes"]+    desirableChangeLogExtensions = ["", ".txt", ".md", ".markdown", ".rst"]++-- [TODO] Check readme. Observations:+--        • Readme is not necessary if package description is good.+--        • Some readmes exists only for repository browsing.+--        • There is currently no reliable way to check what a good+--          description is; there will be complains if the criterion+--          is based on the length or number of words (can of worms).+-- -- Readme patterns+-- -- Source: hackage-server/src/Distribution/Server/Packages/Readme.hs+-- desirableReadme = ["readme"]++-- Remove duplicates from list.+dups :: Ord a => [a] -> [a]+dups xs = [x | (x : _ : _) <- group (sort xs)]
+ src/Distribution/PackageDescription/Check/Common.hs view
@@ -0,0 +1,148 @@+-- |+-- Module      :  Distribution.PackageDescription.Check.Common+-- Copyright   :  Francesco Ariis 2022+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Common types/functions to various check modules which are *no* part of+-- Distribution.PackageDescription.Check.Monad.+module Distribution.PackageDescription.Check.Common+  ( AssocDep+  , CabalField+  , PathKind (..)+  , checkCustomField+  , partitionDeps+  , checkPVP+  , checkPVPs+  , checkDependencyVersionRange+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Compat.NonEmptySet (toNonEmpty)+import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Check.Monad+import Distribution.Utils.Generic (isAscii)+import Distribution.Version++import Control.Monad++-- Type of FilePath.+data PathKind+  = PathKindFile+  | PathKindDirectory+  | PathKindGlob+  deriving (Eq)++-- | .cabal field we are referring to. As now it is just a synonym to help+-- reading the code, in the future it might take advantage of typification+-- in Cabal-syntax.+type CabalField = String++checkCustomField :: Monad m => (String, String) -> CheckM m ()+checkCustomField (n, _) =+  checkP+    (any (not . isAscii) n)+    (PackageDistInexcusable $ NonASCIICustomField [n])++-- ------------------------------------------------------------+-- PVP types/functions+-- ------------------------------------------------------------++-- A library name / dependencies association list. Ultimately to be+-- fed to PVP check.+type AssocDep = (UnqualComponentName, [Dependency])++-- Convenience function to partition important dependencies by name. To+-- 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+-- main library will not need to specify upper bounds on shared dependencies,+-- hence we do not return those).+--+partitionDeps+  :: Monad m+  => [AssocDep] -- Possibly inherited dependencies, i.e.+  -- dependencies from internal/main libs.+  -> [UnqualComponentName] -- List of package names ("base", "Cabal"…)+  -> [Dependency] -- Dependencies to check.+  -> CheckM m ([Dependency], [Dependency])+partitionDeps ads ns ds = do+  -- Shared dependencies from “intra .cabal” libraries.+  let+    -- names of our dependencies+    dqs = map unqualName ds+    -- shared targets that match+    fads = filter (flip elem dqs . fst) ads+    -- the names of such targets+    inName = nub $ map fst fads :: [UnqualComponentName]+    -- the dependencies of such targets+    inDep = concatMap snd fads :: [Dependency]++  -- We exclude from checks:+  -- 1. dependencies which are shared with main library / a+  --    sublibrary; and of course+  -- 2. the names of main library / sub libraries themselves.+  --+  -- So in myPackage.cabal+  -- library+  --      build-depends: text < 5+  -- ⁝+  --      build-depends: myPackage,        ← no warning, internal+  --                     text,             ← no warning, inherited+  --                     monadacme         ← warning!+  let fFun d =+        notElem (unqualName d) inName+          && notElem+            (unqualName d)+            (map unqualName inDep)+      ds' = filter fFun ds++  return $ partition (flip elem ns . unqualName) ds'+  where+    -- Return *sublibrary* name if exists (internal),+    -- otherwise package name.+    unqualName :: Dependency -> UnqualComponentName+    unqualName (Dependency n _ nel) =+      case head (toNonEmpty nel) of+        (LSubLibName ln) -> ln+        _ -> packageNameToUnqualComponentName n++-- PVP dependency check (one warning message per dependency, usually+-- for important dependencies like base).+checkPVP+  :: Monad m+  => (Dependency -> Bool)+  -> (String -> PackageCheck) -- Warn message depends on name+  -- (e.g. "base", "Cabal").+  -> [Dependency]+  -> CheckM m ()+checkPVP p ckf ds = do+  let ods = filter p ds+  mapM_ (tellP . ckf . unPackageName . depPkgName) ods++-- PVP dependency check for a list of dependencies. Some code duplication+-- is sadly needed to provide more ergonimic error messages.+checkPVPs+  :: Monad m+  => (Dependency -> Bool)+  -> ( [String]+       -> PackageCheck -- Grouped error message, depends on a+       -- set of names.+     )+  -> [Dependency] -- Deps to analyse.+  -> CheckM m ()+checkPVPs p cf ds+  | null ns = return ()+  | otherwise = tellP (cf ns)+  where+    ods = filter p ds+    ns = map (unPackageName . depPkgName) ods++checkDependencyVersionRange :: (VersionRange -> Bool) -> Dependency -> Bool+checkDependencyVersionRange p (Dependency _ ver _) = p ver
+ src/Distribution/PackageDescription/Check/Conditional.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      :  Distribution.PackageDescription.Check.Conditional+-- Copyright   :  Lennart Kolmodin 2008, Francesco Ariis 2023+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Checks on conditional targets (libraries, executables, etc. that are+-- still inside a CondTree and related checks that can only be performed+-- here (variables, duplicated modules).+module Distribution.PackageDescription.Check.Conditional+  ( checkCondTarget+  , checkDuplicateModules+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Compiler+import Distribution.ModuleName (ModuleName)+import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Check.Monad+import Distribution.System++import qualified Data.Map as Map++import Control.Monad++-- As a prerequisite to some checks, we transform a target CondTree into+-- a CondTree of “target + useful context”.+-- This is slightly clearer, is easier to walk without resorting to+-- list comprehensions, allows us in the future to apply some sensible+-- “optimisations” to checks (exclusive branches, etc.).++-- | @nf@ function is needed to appropriately name some targets which need+-- to be spoonfed (otherwise name appears as "").+initTargetAnnotation+  :: Monoid a+  => (UnqualComponentName -> a -> a) -- Naming function for targets.+  -> UnqualComponentName+  -> TargetAnnotation a+initTargetAnnotation nf n = TargetAnnotation (nf n mempty) False++-- | We “build up” target from various slices.+updateTargetAnnotation+  :: Monoid a+  => a -- A target (lib, exe, test, …)+  -> TargetAnnotation a+  -> TargetAnnotation a+updateTargetAnnotation t ta = ta{taTarget = taTarget ta <> t}++-- | Before walking a target 'CondTree', we need to annotate it with+-- information relevant to the checks (read 'TaraAnn' and 'checkCondTarget'+-- doc for more info).+annotateCondTree+  :: forall a+   . (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) =+  let ta' = updateTargetAnnotation a ta+      bs' = map (annotateBranch ta') bs+      bs'' = crossAnnotateBranches defTrueFlags bs'+   in CondNode ta' c bs''+  where+    annotateBranch+      :: TargetAnnotation a+      -> CondBranch ConfVar [Dependency] a+      -> CondBranch+          ConfVar+          [Dependency]+          (TargetAnnotation a)+    annotateBranch wta (CondBranch k t mf) =+      let uf = isPkgFlagCond k+          wta' = wta{taPackageFlag = taPackageFlag wta || uf}+          atf = annotateCondTree fs+       in CondBranch+            k+            (atf wta' t)+            (atf wta <$> mf)+    -- Note how we are passing the *old* wta+    -- in the `else` branch, since we are not+    -- under that flag.++    -- We only want to pick up variables that are flags and that are+    -- \*off* by default.+    isPkgFlagCond :: Condition ConfVar -> Bool+    isPkgFlagCond (Lit _) = False+    isPkgFlagCond (Var (PackageFlag f)) = elem f defOffFlags+    isPkgFlagCond (Var _) = False+    isPkgFlagCond (CNot cn) = not (isPkgFlagCond cn)+    isPkgFlagCond (CAnd ca cb) = isPkgFlagCond ca || isPkgFlagCond cb+    isPkgFlagCond (COr ca cb) = isPkgFlagCond ca && isPkgFlagCond cb++    -- Package flags that are off by default *and* that are manual.+    defOffFlags =+      map flagName $+        filter+          ( \f ->+              not (flagDefault f)+                && flagManual f+          )+          fs++    defTrueFlags :: [PackageFlag]+    defTrueFlags = filter flagDefault fs++-- Propagate contextual information in CondTree branches. This is+-- needed as CondTree is a rosetree and not a binary tree.+crossAnnotateBranches+  :: forall a+   . (Eq a, Monoid a)+  => [PackageFlag] -- `default: true` flags.+  -> [CondBranch ConfVar [Dependency] (TargetAnnotation a)]+  -> [CondBranch ConfVar [Dependency] (TargetAnnotation a)]+crossAnnotateBranches fs bs = map crossAnnBranch bs+  where+    crossAnnBranch+      :: CondBranch ConfVar [Dependency] (TargetAnnotation a)+      -> CondBranch ConfVar [Dependency] (TargetAnnotation a)+    crossAnnBranch wr =+      let+        rs = filter (/= wr) bs+        ts = mapMaybe realiseBranch rs+       in+        updateTargetAnnBranch (mconcat ts) wr++    realiseBranch :: CondBranch ConfVar [Dependency] (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++    updateTargetAnnBranch+      :: a+      -> CondBranch ConfVar [Dependency] (TargetAnnotation a)+      -> CondBranch ConfVar [Dependency] (TargetAnnotation a)+    updateTargetAnnBranch a (CondBranch k t mt) =+      let updateTargetAnnTree (CondNode ka c wbs) =+            (CondNode (updateTargetAnnotation a ka) c wbs)+       in CondBranch k (updateTargetAnnTree t) (updateTargetAnnTree <$> mt)++-- | A conditional target is a library, exe, benchmark etc., destructured+-- in a CondTree. Traversing method: we render the branches, pass a+-- relevant context, collect checks.+checkCondTarget+  :: forall m a+   . (Monad m, Eq a, Monoid a)+  => [PackageFlag] -- User flags.+  -> (a -> CheckM m ()) -- Check function (a = target).+  -> (UnqualComponentName -> a -> a)+  -- Naming function (some targets+  -- need to have their name+  -- spoonfed to them.+  -> (UnqualComponentName, CondTree ConfVar [Dependency] a)+  -- Target name/condtree.+  -> CheckM m ()+checkCondTarget fs cf nf (unqualName, ct) =+  wTree $ annotateCondTree fs (initTargetAnnotation nf unqualName) ct+  where+    -- Walking the tree. Remember that CondTree is not a binary+    -- tree but a /rose/tree.+    wTree+      :: CondTree ConfVar [Dependency] (TargetAnnotation a)+      -> CheckM m ()+    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+      -- cases; a more precise way would be to check incompatibility+      -- among simple branches conditions (or introduce a principled+      -- `cond` construct in `.cabal` files.+      | all isSimple bs = do+          localCM (initCheckCtx ta) (cf $ taTarget ta)+          mapM_ wBranch bs+      -- If there are T/F conditions, there is no need to check+      -- the intermediate 'TargetAnnotation' too.+      | otherwise = do+          mapM_ wBranch bs++    isSimple+      :: CondBranch ConfVar [Dependency] (TargetAnnotation a)+      -> Bool+    isSimple (CondBranch _ _ Nothing) = True+    isSimple (CondBranch _ _ (Just _)) = False++    wBranch+      :: CondBranch ConfVar [Dependency] (TargetAnnotation a)+      -> CheckM m ()+    wBranch (CondBranch k t mf) = do+      checkCondVars k+      wTree t+      maybe (return ()) wTree mf++-- | Condvar checking (misspelled OS in if conditions, etc).+checkCondVars :: Monad m => Condition ConfVar -> CheckM m ()+checkCondVars cond =+  let (_, vs) = simplifyCondition cond (\v -> Left v)+   in -- Using simplifyCondition is convenient and correct,+      -- if checks become more complex we can always walk+      -- 'Condition'.+      mapM_ vcheck vs+  where+    vcheck :: Monad m => ConfVar -> CheckM m ()+    vcheck (OS (OtherOS os)) =+      tellP (PackageDistInexcusable $ UnknownOS [os])+    vcheck (Arch (OtherArch arch)) =+      tellP (PackageDistInexcusable $ UnknownArch [arch])+    vcheck (Impl (OtherCompiler os) _) =+      tellP (PackageDistInexcusable $ UnknownCompiler [os])+    vcheck _ = return ()++-- Checking duplicated modules cannot unfortunately be done in the+-- “tree checking”. This is because of the monoidal instance in some targets,+-- where e.g. merged dependencies are `nub`’d, hence losing information for+-- this particular check.+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)+  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 s getModules t =+      let sumPair (x, x') (y, y') = (x + x' :: Int, y + y' :: Int)+          mergePair (x, x') (y, y') = (x + x', max y y')+          maxPair (x, x') (y, y') = (max x x', max y y')+          libMap =+            foldCondTree+              Map.empty+              (\(_, v) -> Map.fromListWith sumPair . map (\x -> (x, (1, 1))) $ getModules v)+              (Map.unionWith mergePair) -- if a module may occur in nonexclusive branches count it twice strictly and once loosely.+              (Map.unionWith maxPair) -- a module occurs the max of times it might appear in exclusive branches+              t+          dupLibsStrict = Map.keys $ Map.filter ((> 1) . fst) libMap+          dupLibsLax = Map.keys $ Map.filter ((> 1) . snd) libMap+       in if not (null dupLibsLax)+            then+              [ PackageBuildImpossible+                  (DuplicateModule s dupLibsLax)+              ]+            else+              if not (null dupLibsStrict)+                then+                  [ PackageDistSuspicious+                      (PotentialDupModule s dupLibsStrict)+                  ]+                else []
+ src/Distribution/PackageDescription/Check/Monad.hs view
@@ -0,0 +1,371 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      :  Distribution.PackageDescription.Check.Monad+-- Copyright   :  Francesco Ariis 2022+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Primitives for package checking: check types and monadic interface.+-- Having these primitives in a different module allows us to appropriately+-- limit/manage the interface to suit checking needs.+module Distribution.PackageDescription.Check.Monad+  ( -- * Types and constructors+    CheckM (..)+  , execCheckM+  , CheckInterface (..)+  , CheckPackageContentOps (..)+  , CheckPreDistributionOps (..)+  , TargetAnnotation (..)+  , PackageCheck (..)+  , CheckExplanation (..)+  , CEType (..)+  , WarnLang (..)+  , CheckCtx (..)+  , pristineCheckCtx+  , initCheckCtx+  , PNames (..)++    -- * Operations+  , ppPackageCheck+  , isHackageDistError+  , asksCM+  , localCM+  , checkP+  , checkPkg+  , liftInt+  , tellP+  , checkSpecVer+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.CabalSpecVersion (CabalSpecVersion)+import Distribution.Package (packageName)+import Distribution.PackageDescription.Check.Warning+import Distribution.Simple.BuildToolDepends (desugarBuildToolSimple)+import Distribution.Simple.Glob (Glob, GlobResult)+import Distribution.Types.ExeDependency (ExeDependency)+import Distribution.Types.GenericPackageDescription+import Distribution.Types.LegacyExeDependency (LegacyExeDependency)+import Distribution.Types.PackageDescription (package, specVersion)+import Distribution.Types.PackageId (PackageIdentifier)+import Distribution.Types.UnqualComponentName++import qualified Control.Monad.Reader as Reader+import qualified Control.Monad.Trans.Class as Trans+import qualified Control.Monad.Writer as Writer+import qualified Data.ByteString.Lazy as BS+import qualified Data.Set as Set++import Control.Monad++-- Monadic interface for for Distribution.PackageDescription.Check.+--+-- Monadic checking allows us to have a fine grained control on checks+-- (e.g. omitting warning checks in certain situations).++-- * Interfaces++--++-- | Which interface to we have available/should we use? (to perform: pure+-- checks, package checks, pre-distribution checks.)+data CheckInterface m = CheckInterface+  { ciPureChecks :: Bool+  , -- Perform pure checks?+    ciPackageOps :: Maybe (CheckPackageContentOps m)+  , -- If you want to perform package contents+    -- checks, provide an interface.+    ciPreDistOps :: Maybe (CheckPreDistributionOps m)+    -- If you want to work-tree checks, provide+    -- an interface.+  }++-- | A record of operations needed to check the contents of packages.+-- Abstracted over `m` to provide flexibility (could be IO, a .tar.gz+-- file, etc).+data CheckPackageContentOps m = CheckPackageContentOps+  { doesFileExist :: FilePath -> m Bool+  , doesDirectoryExist :: FilePath -> m Bool+  , getDirectoryContents :: FilePath -> m [FilePath]+  , getFileContents :: FilePath -> m BS.ByteString+  }++-- | A record of operations needed to check contents *of the work tree*+-- (compare it with 'CheckPackageContentOps'). This is still `m` abstracted+-- in case in the future we can obtain the same infos other than from IO+-- (e.g. a VCS work tree).+data CheckPreDistributionOps m = CheckPreDistributionOps+  { runDirFileGlobM :: FilePath -> Glob -> m [GlobResult FilePath]+  , getDirectoryContentsM :: FilePath -> m [FilePath]+  }++-- | Context to perform checks (will be the Reader part in your monad).+data CheckCtx m = CheckCtx+  { ccInterface :: CheckInterface m+  , -- Interface for checks.++    -- Contextual infos for checks.+    ccFlag :: Bool+  , -- Are we under a user flag?++    -- Convenience bits that we prefer to carry+    -- in our Reader monad instead of passing it+    -- via ->, as they are often useful and often+    -- in deeply nested places in the GPD tree.+    ccSpecVersion :: CabalSpecVersion+  , -- Cabal version.+    ccDesugar :: LegacyExeDependency -> Maybe ExeDependency+  , -- A desugaring function from+    -- Distribution.Simple.BuildToolDepends+    -- (desugarBuildToolSimple). Again since it+    -- eats PackageName and a list of executable+    -- names, it is more convenient to pass it+    -- via Reader.+    ccNames :: PNames+    -- Various names (id, libs, execs, tests,+    -- benchs), convenience.+  }++-- | 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+  -> GenericPackageDescription+  -> CheckCtx m+pristineCheckCtx ci gpd =+  let ens = map fst (condExecutables gpd)+   in CheckCtx+        ci+        False+        (specVersion . packageDescription $ gpd)+        (desugarBuildToolSimple (packageName gpd) ens)+        (initPNames gpd)++-- | 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 t c = c{ccFlag = taPackageFlag t}++-- | 'TargetAnnotation' collects contextual information on the target we are+-- realising: a buildup of the various slices of the target (a library,+-- executable, etc. — is a monoid) whether we are under an off-by-default+-- package flag.+data TargetAnnotation a = TargetAnnotation+  { taTarget :: a+  , -- The target we are building (lib, exe, etc.)+    taPackageFlag :: Bool+    -- Whether we are under an off-by-default package flag.+  }+  deriving (Show, Eq, Ord)++-- | A collection os names, shipping tuples around is annoying.+data PNames = PNames+  { pnPackageId :: PackageIdentifier -- Package ID…+  -- … and a bunch of lib, exe, test, bench names.+  , pnSubLibs :: [UnqualComponentName]+  , pnExecs :: [UnqualComponentName]+  , pnTests :: [UnqualComponentName]+  , pnBenchs :: [UnqualComponentName]+  }++-- | Init names from a GPD.+initPNames :: GenericPackageDescription -> PNames+initPNames gpd =+  PNames+    (package . packageDescription $ gpd)+    (map fst $ condSubLibraries gpd)+    (map fst $ condExecutables gpd)+    (map fst $ condTestSuites gpd)+    (map fst $ condBenchmarks gpd)++-- | Check monad, carrying a context, collecting 'PackageCheck's.+-- Using Set for writer (automatic sort) is useful for output stability+-- on different platforms.+-- It is nothing more than a monad stack with Reader+Writer.+-- `m` is the monad that could be used to do package/file checks.+newtype CheckM m a+  = CheckM+      ( Reader.ReaderT+          (CheckCtx m)+          ( Writer.WriterT+              (Set.Set PackageCheck)+              m+          )+          a+      )+  deriving (Functor, Applicative, Monad)++-- Not autoderiving MonadReader and MonadWriter gives us better+-- control on the interface of CheckM.++-- | Execute a CheckM monad, leaving `m [PackageCheck]` which can be+-- run in the appropriate `m` environment (IO, pure, …).+execCheckM :: Monad m => CheckM m () -> CheckCtx m -> m [PackageCheck]+execCheckM (CheckM rwm) ctx =+  let wm = Reader.runReaderT rwm ctx+      m = Writer.execWriterT wm+   in Set.toList <$> m++-- | As 'checkP' but always succeeding.+tellP :: Monad m => PackageCheck -> CheckM m ()+tellP = checkP True++-- | Add a package warning withoutu performing any check.+tellCM :: Monad m => PackageCheck -> CheckM m ()+tellCM ck = do+  cf <- asksCM ccFlag+  unless+    (cf && canSkip ck)+    -- Do not push this message if the warning is not severe *and*+    -- we are under a non-default package flag.+    (CheckM . Writer.tell $ Set.singleton ck)+  where+    -- Check if we can skip this error if we are under a+    -- non-default user flag.+    canSkip :: PackageCheck -> Bool+    canSkip wck = not (isSevereLocal wck) || isErrAllowable wck++    isSevereLocal :: PackageCheck -> Bool+    isSevereLocal (PackageBuildImpossible _) = True+    isSevereLocal (PackageBuildWarning _) = True+    isSevereLocal (PackageDistSuspicious _) = False+    isSevereLocal (PackageDistSuspiciousWarn _) = False+    isSevereLocal (PackageDistInexcusable _) = True++    -- 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 extractCheckExplanation c of+      (WErrorUnneeded _) -> True+      (JUnneeded _) -> True+      (FDeferTypeErrorsUnneeded _) -> True+      (DynamicUnneeded _) -> True+      (ProfilingUnneeded _) -> True+      _ -> False++-- | Lift a monadic computation to CM.+liftCM :: Monad m => m a -> CheckM m a+liftCM ma = CheckM . Trans.lift . Trans.lift $ ma++-- | Lift a monadic action via an interface. Missing interface, no action.+liftInt+  :: forall m i+   . Monad m+  => (CheckInterface m -> Maybe (i m))+  -- Check interface, may or may not exist. If it does not,+  -- the check simply will not be performed.+  -> (i m -> m [PackageCheck])+  -- The actual check to perform with the above-mentioned+  -- interface. Note the [] around `PackageCheck`, this is+  -- meant to perform/collect multiple checks.+  -> CheckM m ()+liftInt acc f = do+  ops <- asksCM (acc . ccInterface)+  maybe (return ()) l ops+  where+    l :: i m -> CheckM m ()+    l wi = do+      cks <- liftCM (f wi)+      mapM_ (check True) cks++-- | Most basic check function. You do not want to export this, rather export+-- “smart” functions (checkP, checkPkg) to enforce relevant properties.+check+  :: Monad m+  => Bool -- Is there something to warn about?+  -> PackageCheck -- Warn message.+  -> CheckM m ()+check True ck = tellCM ck+check False _ = return ()++-- | Pure check not requiring IO or other interfaces.+checkP+  :: Monad m+  => Bool -- Is there something to warn about?+  -> PackageCheck -- Warn message.+  -> CheckM m ()+checkP b ck = do+  pb <- asksCM (ciPureChecks . ccInterface)+  when pb (check b ck)++-- Check with 'CheckPackageContentOps' operations (i.e. package file checks).+--+checkPkg+  :: forall m+   . Monad m+  => (CheckPackageContentOps m -> m Bool)+  -- Actual check to perform with CPC interface+  -> PackageCheck+  -- Warn message.+  -> CheckM m ()+checkPkg f ck = checkInt ciPackageOps f ck++-- | Generalised version for checks that need an interface. We pass a Reader+-- accessor to such interface ‘i’, a check function.+checkIntDep+  :: forall m i+   . Monad m+  => (CheckInterface m -> Maybe (i m))+  -- Check interface, may or may not exist. If it does not,+  -- the check simply will not be performed.+  -> (i m -> m (Maybe PackageCheck))+  -- The actual check to perform (single check).+  -> CheckM m ()+checkIntDep acc mck = do+  po <- asksCM (acc . ccInterface)+  maybe (return ()) (lc . mck) po+  where+    lc :: Monad m => m (Maybe PackageCheck) -> CheckM m ()+    lc wmck = do+      b <- liftCM wmck+      maybe (return ()) (check True) b++-- | As 'checkIntDep', but 'PackageCheck' does not depend on the monadic+-- computation.+checkInt+  :: forall m i+   . Monad m+  => (CheckInterface m -> Maybe (i m))+  -- Where to get the interface (if available).+  -> (i m -> m Bool)+  -- Condition to check+  -> PackageCheck+  -- Warning message to add (does not depend on `m`).+  -> CheckM m ()+checkInt acc f ck =+  checkIntDep+    acc+    ( \ops -> do+        b <- f ops+        if b+          then return $ Just ck+          else return Nothing+    )++-- | `local` (from Control.Monad.Reader) for CheckM.+localCM :: Monad m => (CheckCtx m -> CheckCtx m) -> CheckM m () -> CheckM m ()+localCM cf (CheckM im) = CheckM $ Reader.local cf im++-- | `ask` (from Control.Monad.Reader) for CheckM.+asksCM :: Monad m => (CheckCtx m -> a) -> CheckM m a+asksCM f = CheckM $ Reader.asks f++-- As checkP, but with an additional condition: the check will be performed+-- only if our spec version is < `vc`.+checkSpecVer+  :: Monad m+  => CabalSpecVersion -- Perform this check only if our+  -- spec version is < than this.+  -> Bool -- Check condition.+  -> PackageCheck -- Check message.+  -> CheckM m ()+checkSpecVer vc cond c = do+  vp <- asksCM ccSpecVersion+  unless (vp >= vc) (checkP cond c)
+ src/Distribution/PackageDescription/Check/Paths.hs view
@@ -0,0 +1,418 @@+-- |+-- Module      :  Distribution.PackageDescription.Check.Paths+-- Copyright   :  Lennart Kolmodin 2008, Francesco Ariis 2023+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Functions to check filepaths, directories, globs, etc.+module Distribution.PackageDescription.Check.Paths+  ( checkGlob+  , checkPath+  , checkPackageFileNamesWithGlob+  , fileExtensionSupportedLanguage+  , isGoodRelativeDirectoryPath+  , isGoodRelativeFilePath+  , isGoodRelativeGlob+  , isInsideDist+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.PackageDescription.Check.Common+import Distribution.PackageDescription.Check.Monad+import Distribution.Simple.CCompiler+import Distribution.Simple.Glob+  ( Glob+  , explainGlobSyntaxError+  , isRecursiveInRoot+  , parseFileGlob+  )+import Distribution.Simple.Utils hiding (findPackageDesc, notice)+import System.FilePath (splitDirectories, splitPath, takeExtension)++import qualified System.FilePath.Windows as FilePath.Windows (isValid)++fileExtensionSupportedLanguage :: FilePath -> Bool+fileExtensionSupportedLanguage path =+  isHaskell || isC+  where+    extension = takeExtension path+    isHaskell = extension `elem` [".hs", ".lhs"]+    isC = isJust (filenameCDialect extension)++-- Boolean: are absolute paths allowed?+checkPath+  :: Monad m+  => Bool -- Can be absolute path?+  -> CabalField -- .cabal field that we are checking.+  -> PathKind -- Path type.+  -> FilePath -- Path.+  -> CheckM m ()+checkPath isAbs title kind path = do+  checkP+    (isOutsideTree path)+    (PackageBuildWarning $ RelativeOutside title path)+  checkP+    (isInsideDist path)+    (PackageDistInexcusable $ DistPoint (Just title) path)+  checkPackageFileNamesWithGlob kind path++  -- Skip if "can be absolute path".+  checkP+    (not isAbs && isAbsoluteOnAnyPlatform path)+    (PackageDistInexcusable $ AbsolutePath title path)+  case grl path kind of+    Just e ->+      checkP+        (not isAbs)+        (PackageDistInexcusable $ BadRelativePath title path e)+    Nothing -> return ()+  checkWindowsPath (kind == PathKindGlob) path+  where+    isOutsideTree wpath = case splitDirectories wpath of+      ".." : _ -> True+      "." : ".." : _ -> True+      _ -> False++    -- These are not paths, but globs...+    grl wfp PathKindFile = isGoodRelativeFilePath wfp+    grl wfp PathKindGlob = isGoodRelativeGlob wfp+    grl wfp PathKindDirectory = isGoodRelativeDirectoryPath wfp++-- | Is a 'FilePath' inside `dist`, `dist-newstyle` and friends?+isInsideDist :: FilePath -> Bool+isInsideDist path =+  case map lowercase (splitDirectories path) of+    "dist" : _ -> True+    "." : "dist" : _ -> True+    "dist-newstyle" : _ -> True+    "." : "dist-newstyle" : _ -> True+    _ -> False++checkPackageFileNamesWithGlob+  :: Monad m+  => PathKind+  -> FilePath -- Filepath or possibly a glob pattern.+  -> CheckM m ()+checkPackageFileNamesWithGlob kind fp = do+  checkWindowsPath (kind == PathKindGlob) fp+  checkTarPath fp++checkWindowsPath+  :: Monad m+  => Bool -- Is it a glob pattern?+  -> FilePath -- Path.+  -> CheckM m ()+checkWindowsPath isGlob path =+  checkP+    (not . FilePath.Windows.isValid $ escape isGlob path)+    (PackageDistInexcusable $ InvalidOnWin [path])+  where+    -- Force a relative name to catch invalid file names like "f:oo" which+    -- otherwise parse as file "oo" in the current directory on the 'f' drive.+    escape :: Bool -> String -> String+    escape wisGlob wpath =+      (".\\" ++)+      -- Glob paths will be expanded before being dereferenced, so asterisks+      -- shouldn't count against them.+      $+        map (\c -> if c == '*' && wisGlob then 'x' else c) wpath++-- | Check a file name is valid for the portable POSIX tar format.+--+-- The POSIX tar format has a restriction on the length of file names. It is+-- unfortunately not a simple restriction like a maximum length. The exact+-- restriction is that either the whole path be 100 characters or less, or it+-- be possible to split the path on a directory separator such that the first+-- part is 155 characters or less and the second part 100 characters or less.+checkTarPath :: Monad m => FilePath -> CheckM m ()+checkTarPath path+  | length path > 255 = tellP longPath+  | otherwise = case pack nameMax (reverse (splitPath path)) of+      Left err -> tellP err+      Right [] -> return ()+      Right (h : rest) -> case pack prefixMax remainder of+        Left err -> tellP err+        Right [] -> return ()+        Right (_ : _) -> tellP noSplit+        where+          -- drop the '/' between the name and prefix:+          remainder = safeInit h : rest+  where+    nameMax, prefixMax :: Int+    nameMax = 100+    prefixMax = 155++    pack _ [] = Left emptyName+    pack maxLen (c : cs)+      | n > maxLen = Left longName+      | otherwise = Right (pack' maxLen n cs)+      where+        n = length c++    pack' maxLen n (c : cs)+      | n' <= maxLen = pack' maxLen n' cs+      where+        n' = n + length c+    pack' _ _ cs = cs++    longPath = PackageDistInexcusable (FilePathTooLong path)+    longName = PackageDistInexcusable (FilePathNameTooLong path)+    noSplit = PackageDistInexcusable (FilePathSplitTooLong path)+    emptyName = PackageDistInexcusable FilePathEmpty++-- `checkGlob` checks glob patterns and returns good ones for further+-- processing.+checkGlob+  :: Monad m+  => CabalField -- .cabal field we are checking.+  -> FilePath -- glob filepath pattern+  -> CheckM m (Maybe Glob)+checkGlob title pat = do+  ver <- asksCM ccSpecVersion++  -- Glob sanity check.+  case parseFileGlob ver pat of+    Left e -> do+      tellP+        ( PackageDistInexcusable $+            GlobSyntaxError title (explainGlobSyntaxError pat e)+        )+      return Nothing+    Right wglob -> do+      -- \* Miscellaneous checks on sane glob.+      -- Checks for recursive glob in root.+      checkP+        (isRecursiveInRoot wglob)+        ( PackageDistSuspiciousWarn $+            RecursiveGlobInRoot title pat+        )+      return (Just wglob)++-- | Whether a path is a good relative path.  We aren't worried about perfect+-- cross-platform compatibility here; this function just checks the paths in+-- the (local) @.cabal@ file, while only Hackage needs the portability.+--+-- >>> let test fp = putStrLn $ show (isGoodRelativeDirectoryPath fp) ++ "; " ++ show (isGoodRelativeFilePath fp)+--+-- Note that "foo./bar.hs" would be invalid on Windows.+--+-- >>> traverse_ test ["foo/bar/quu", "a/b.hs", "foo./bar.hs"]+-- Nothing; Nothing+-- Nothing; Nothing+-- Nothing; Nothing+--+-- Trailing slash is not allowed for files, for directories it is ok.+--+-- >>> test "foo/"+-- Nothing; Just "trailing slash"+--+-- Leading @./@ is fine, but @.@ and @./@ are not valid files.+--+-- >>> traverse_ test [".", "./", "./foo/bar"]+-- Nothing; Just "trailing dot segment"+-- Nothing; Just "trailing slash"+-- Nothing; Nothing+--+-- Lastly, not good file nor directory cases:+--+-- >>> traverse_ test ["", "/tmp/src", "foo//bar", "foo/.", "foo/./bar", "foo/../bar"]+-- Just "empty path"; Just "empty path"+-- Just "posix absolute path"; Just "posix absolute path"+-- Just "empty path segment"; Just "empty path segment"+-- Just "trailing same directory segment: ."; Just "trailing same directory segment: ."+-- Just "same directory segment: ."; Just "same directory segment: ."+-- Just "parent directory segment: .."; Just "parent directory segment: .."+--+-- For the last case, 'isGoodRelativeGlob' doesn't warn:+--+-- >>> traverse_ (print . isGoodRelativeGlob) ["foo/../bar"]+-- Just "parent directory segment: .."+isGoodRelativeFilePath :: FilePath -> Maybe String+isGoodRelativeFilePath = state0+  where+    -- initial state+    state0 [] = Just "empty path"+    state0 (c : cs)+      | c == '.' = state1 cs+      | c == '/' = Just "posix absolute path"+      | otherwise = state5 cs++    -- after initial .+    state1 [] = Just "trailing dot segment"+    state1 (c : cs)+      | c == '.' = state4 cs+      | c == '/' = state2 cs+      | otherwise = state5 cs++    -- after ./ or after / between segments+    state2 [] = Just "trailing slash"+    state2 (c : cs)+      | c == '.' = state3 cs+      | c == '/' = Just "empty path segment"+      | otherwise = state5 cs++    -- after non-first segment's .+    state3 [] = Just "trailing same directory segment: ."+    state3 (c : cs)+      | c == '.' = state4 cs+      | c == '/' = Just "same directory segment: ."+      | otherwise = state5 cs++    -- after ..+    state4 [] = Just "trailing parent directory segment: .."+    state4 (c : cs)+      | c == '.' = state5 cs+      | c == '/' = Just "parent directory segment: .."+      | otherwise = state5 cs++    -- in a segment which is ok.+    state5 [] = Nothing+    state5 (c : cs)+      | c == '.' = state5 cs+      | c == '/' = state2 cs+      | otherwise = state5 cs++-- | See 'isGoodRelativeFilePath'.+--+-- This is barebones function. We check whether the glob is a valid file+-- by replacing stars @*@ with @x@ses.+isGoodRelativeGlob :: FilePath -> Maybe String+isGoodRelativeGlob = isGoodRelativeFilePath . map f+  where+    f '*' = 'x'+    f c = c++-- | See 'isGoodRelativeFilePath'.+isGoodRelativeDirectoryPath :: FilePath -> Maybe String+isGoodRelativeDirectoryPath = state0+  where+    -- initial state+    state0 [] = Just "empty path"+    state0 (c : cs)+      | c == '.' = state5 cs+      | c == '/' = Just "posix absolute path"+      | otherwise = state4 cs++    -- after initial ./ or after / between segments+    state1 [] = Nothing+    state1 (c : cs)+      | c == '.' = state2 cs+      | c == '/' = Just "empty path segment"+      | otherwise = state4 cs++    -- after non-first setgment's .+    state2 [] = Just "trailing same directory segment: ."+    state2 (c : cs)+      | c == '.' = state3 cs+      | c == '/' = Just "same directory segment: ."+      | otherwise = state4 cs++    -- after ..+    state3 [] = Just "trailing parent directory segment: .."+    state3 (c : cs)+      | c == '.' = state4 cs+      | c == '/' = Just "parent directory segment: .."+      | otherwise = state4 cs++    -- in a segment which is ok.+    state4 [] = Nothing+    state4 (c : cs)+      | c == '.' = state4 cs+      | c == '/' = state1 cs+      | otherwise = state4 cs++    -- after initial .+    state5 [] = Nothing -- "."+    state5 (c : cs)+      | c == '.' = state3 cs+      | c == '/' = state1 cs+      | otherwise = state4 cs++-- [Note: Good relative paths]+--+-- Using @kleene@ we can define an extended regex:+--+-- @+-- import Algebra.Lattice+-- import Kleene+-- import Kleene.ERE (ERE (..), intersections)+--+-- data C = CDot | CSlash | CChar+--   deriving (Eq, Ord, Enum, Bounded, Show)+--+-- reservedR :: ERE C+-- reservedR = notChar CSlash+--+-- pathPieceR :: ERE C+-- pathPieceR = intersections+--     [ plus reservedR+--     , ERENot (string [CDot])+--     , ERENot (string [CDot,CDot])+--     ]+--+-- filePathR :: ERE C+-- filePathR = optional (string [CDot, CSlash]) <> pathPieceR <> star (char CSlash <> pathPieceR)+--+-- dirPathR :: ERE C+-- dirPathR = (char CDot \/ filePathR) <> optional (char CSlash)+--+-- plus :: ERE C -> ERE C+-- plus r = r <> star r+--+-- optional :: ERE C -> ERE C+-- optional r = mempty \/ r+-- @+--+-- Results in following state machine for @filePathR@+--+-- @+-- 0 -> \x -> if+--     | x <= CDot           -> 1+--     | otherwise           -> 5+-- 1 -> \x -> if+--     | x <= CDot           -> 4+--     | x <= CSlash         -> 2+--     | otherwise           -> 5+-- 2 -> \x -> if+--     | x <= CDot           -> 3+--     | otherwise           -> 5+-- 3 -> \x -> if+--     | x <= CDot           -> 4+--     | otherwise           -> 5+-- 4 -> \x -> if+--     | x <= CDot           -> 5+--     | otherwise           -> 5+-- 5+ -> \x -> if+--     | x <= CDot           -> 5+--     | x <= CSlash         -> 2+--     | otherwise           -> 5+-- @+--+-- and @dirPathR@:+--+-- @+-- 0 -> \x -> if+--     | x <= CDot           -> 5+--     | otherwise           -> 4+-- 1+ -> \x -> if+--     | x <= CDot           -> 2+--     | otherwise           -> 4+-- 2 -> \x -> if+--     | x <= CDot           -> 3+--     | otherwise           -> 4+-- 3 -> \x -> if+--     | x <= CDot           -> 4+--     | otherwise           -> 4+-- 4+ -> \x -> if+--     | x <= CDot           -> 4+--     | x <= CSlash         -> 1+--     | otherwise           -> 4+-- 5+ -> \x -> if+--     | x <= CDot           -> 3+--     | x <= CSlash         -> 1+--     | otherwise           -> 4+-- @
+ src/Distribution/PackageDescription/Check/Target.hs view
@@ -0,0 +1,1119 @@+-- |+-- Module      :  Distribution.PackageDescription.Check.Target+-- Copyright   :  Lennart Kolmodin 2008, Francesco Ariis 2023+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Fully-realised target (library, executable, …) checking functions.+module Distribution.PackageDescription.Check.Target+  ( checkLibrary+  , checkForeignLib+  , checkExecutable+  , checkTestSuite+  , checkBenchmark+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.CabalSpecVersion+import Distribution.Compat.Lens+import Distribution.Compiler+import Distribution.ModuleName (ModuleName, toFilePath)+import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Check.Common+import Distribution.PackageDescription.Check.Monad+import Distribution.PackageDescription.Check.Paths+import Distribution.Pretty (prettyShow)+import Distribution.Simple.BuildPaths+  ( autogenPackageInfoModuleName+  , autogenPathsModuleName+  )+import Distribution.Simple.Utils hiding (findPackageDesc, notice)+import Distribution.Types.PackageName.Magic+import Distribution.Utils.Path+import Distribution.Version+import Language.Haskell.Extension+import System.FilePath (takeExtension)++import Control.Monad++import qualified Distribution.Types.BuildInfo.Lens as L++checkLibrary+  :: Monad m+  => Bool -- Is this a sublibrary?+  -> [AssocDep] -- “Inherited” dependencies for PVP checks.+  -> Library+  -> CheckM m ()+checkLibrary+  isSub+  ads+  lib@( Library+          libName_+          _exposedModules_+          reexportedModules_+          signatures_+          _libExposed_+          _libVisibility_+          libBuildInfo_+        ) = do+    mapM_ checkModuleName (explicitLibModules lib)++    checkP+      (libName_ == LMainLibName && isSub)+      (PackageBuildImpossible UnnamedInternal)+    -- TODO: bogus if a required-signature was passed through.+    checkP+      (null (explicitLibModules lib) && null reexportedModules_)+      (PackageDistSuspiciousWarn (NoModulesExposed libName_))+    -- TODO parse-caught check, can safely remove.+    checkSpecVer+      CabalSpecV2_0+      (not . null $ signatures_)+      (PackageDistInexcusable SignaturesCabal2)+    -- autogen/includes checks.+    checkP+      ( not $+          all+            (flip elem (explicitLibModules lib))+            (libModulesAutogen lib)+      )+      (PackageBuildImpossible AutogenNotExposed)+    -- check that all autogen-includes appear on includes or+    -- install-includes.+    checkP+      ( not $+          all+            (flip elem (allExplicitIncludes lib) . getSymbolicPath)+            (view L.autogenIncludes lib)+      )+      $ (PackageBuildImpossible AutogenIncludesNotIncluded)++    -- § Build infos.+    checkBuildInfo+      (CETLibrary libName_)+      (explicitLibModules lib)+      ads+      libBuildInfo_++    -- Feature checks.+    -- check use of reexported-modules sections+    checkSpecVer+      CabalSpecV1_22+      (not . null $ reexportedModules_)+      (PackageDistInexcusable CVReexported)+    where+      allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath]+      allExplicitIncludes x =+        map getSymbolicPath (view L.includes x)+          ++ map getSymbolicPath (view L.installIncludes x)++checkForeignLib :: Monad m => ForeignLib -> CheckM m ()+checkForeignLib+  ( ForeignLib+      foreignLibName_+      _foreignLibType_+      _foreignLibOptions_+      foreignLibBuildInfo_+      _foreignLibVersionInfo_+      _foreignLibVersionLinux_+      _foreignLibModDefFile_+    ) = do+    checkBuildInfo+      (CETForeignLibrary foreignLibName_)+      []+      []+      foreignLibBuildInfo_++checkExecutable+  :: Monad m+  => [AssocDep] -- “Inherited” dependencies for PVP checks.+  -> Executable+  -> CheckM m ()+checkExecutable+  ads+  exe@( Executable+          exeName_+          symbolicModulePath_+          _exeScope_+          buildInfo_+        ) = do+    -- Target type/name (exe).+    let cet = CETExecutable exeName_+        modulePath_ = getSymbolicPath symbolicModulePath_++    mapM_ checkModuleName (exeModules exe)++    -- § Exe specific checks+    checkP+      (null modulePath_)+      (PackageBuildImpossible (NoMainIs exeName_))+    -- This check does not apply to scripts.+    pid <- asksCM (pnPackageId . ccNames)+    checkP+      ( pid /= fakePackageId+          && not (null modulePath_)+          && not (fileExtensionSupportedLanguage $ modulePath_)+      )+      (PackageBuildImpossible NoHsLhsMain)++    -- § Features check+    checkSpecVer+      CabalSpecV1_18+      ( fileExtensionSupportedLanguage modulePath_+          && takeExtension modulePath_ `notElem` [".hs", ".lhs"]+      )+      (PackageDistInexcusable MainCCabal1_18)++    -- Alas exeModules ad exeModulesAutogen (exported from+    -- Distribution.Types.Executable) take `Executable` as a parameter.+    checkP+      (not $ all (flip elem (exeModules exe)) (exeModulesAutogen exe))+      (PackageBuildImpossible $ AutogenNoOther cet)+    checkP+      ( not $+          all+            (flip elem (view L.includes exe) . relativeSymbolicPath)+            (view L.autogenIncludes exe)+      )+      (PackageBuildImpossible AutogenIncludesNotIncludedExe)++    -- § Build info checks.+    checkBuildInfo cet [] ads buildInfo_++checkTestSuite+  :: Monad m+  => [AssocDep] -- “Inherited” dependencies for PVP checks.+  -> TestSuite+  -> CheckM m ()+checkTestSuite+  ads+  ts@( TestSuite+        testName_+        testInterface_+        testBuildInfo_+        _testCodeGenerators_+      ) = do+    -- Target type/name (test).+    let cet = CETTest testName_++    -- § TS specific checks.+    -- TODO caught by the parser, can remove safely+    case testInterface_ of+      TestSuiteUnsupported tt@(TestTypeUnknown _ _) ->+        tellP (PackageBuildWarning $ TestsuiteTypeNotKnown tt)+      TestSuiteUnsupported tt ->+        tellP (PackageBuildWarning $ TestsuiteNotSupported tt)+      _ -> return ()++    mapM_ checkModuleName (testModules ts)++    checkP+      mainIsWrongExt+      (PackageBuildImpossible NoHsLhsMain)+    checkP+      ( not $+          all+            (flip elem (testModules ts))+            (testModulesAutogen ts)+      )+      (PackageBuildImpossible $ AutogenNoOther cet)+    checkP+      ( not $+          all+            (flip elem (view L.includes ts) . relativeSymbolicPath)+            (view L.autogenIncludes ts)+      )+      (PackageBuildImpossible AutogenIncludesNotIncludedExe)++    -- § Feature checks.+    checkSpecVer+      CabalSpecV1_18+      (mainIsNotHsExt && not mainIsWrongExt)+      (PackageDistInexcusable MainCCabal1_18)++    -- § Build info checks.+    checkBuildInfo cet [] ads testBuildInfo_+    where+      mainIsWrongExt =+        case testInterface_ of+          TestSuiteExeV10 _ f -> not (fileExtensionSupportedLanguage $ getSymbolicPath f)+          _ -> False++      mainIsNotHsExt =+        case testInterface_ of+          TestSuiteExeV10 _ f -> takeExtension (getSymbolicPath f) `notElem` [".hs", ".lhs"]+          _ -> False++checkBenchmark+  :: Monad m+  => [AssocDep] -- “Inherited” dependencies for PVP checks.+  -> Benchmark+  -> CheckM m ()+checkBenchmark+  ads+  bm@( Benchmark+        benchmarkName_+        benchmarkInterface_+        benchmarkBuildInfo_+      ) = do+    -- Target type/name (benchmark).+    let cet = CETBenchmark benchmarkName_++    mapM_ checkModuleName (benchmarkModules bm)++    -- § Interface & bm specific tests.+    case benchmarkInterface_ of+      BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) ->+        tellP (PackageBuildWarning $ BenchmarkTypeNotKnown tt)+      BenchmarkUnsupported tt ->+        tellP (PackageBuildWarning $ BenchmarkNotSupported tt)+      _ -> return ()+    checkP+      mainIsWrongExt+      (PackageBuildImpossible NoHsLhsMainBench)++    checkP+      ( not $+          all+            (flip elem (benchmarkModules bm))+            (benchmarkModulesAutogen bm)+      )+      (PackageBuildImpossible $ AutogenNoOther cet)++    checkP+      ( not $+          all+            (flip elem (view L.includes bm) . relativeSymbolicPath)+            (view L.autogenIncludes bm)+      )+      (PackageBuildImpossible AutogenIncludesNotIncludedExe)++    -- § BuildInfo checks.+    checkBuildInfo cet [] ads benchmarkBuildInfo_+    where+      -- Cannot abstract with similar function in checkTestSuite,+      -- they are different.+      mainIsWrongExt =+        case benchmarkInterface_ of+          BenchmarkExeV10 _ f -> takeExtension (getSymbolicPath f) `notElem` [".hs", ".lhs"]+          _ -> False++-- | Check if a module name is valid on both Windows and Posix systems+checkModuleName :: Monad m => ModuleName -> CheckM m ()+checkModuleName moduleName =+  checkPackageFileNamesWithGlob PathKindFile (toFilePath moduleName)++-- ------------------------------------------------------------+-- Build info+-- ------------------------------------------------------------++-- Check a great deal of things in buildInfo.+-- With 'checkBuildInfo' we cannot follow the usual “pattern match+-- everything” method, for the number of BuildInfo fields (almost 50)+-- but more importantly because accessing options, etc. is done+-- with functions from 'Distribution.Types.BuildInfo' (e.g. 'hcOptions').+-- Duplicating the effort here means risk of diverging definitions for+-- little gain (most likely if a field is added to BI, the relevant+-- function will be tweaked in Distribution.Types.BuildInfo too).+checkBuildInfo+  :: Monad m+  => CEType -- Name and type of the target.+  -> [ModuleName] -- Additional module names which cannot be+  -- extracted from BuildInfo (mainly: exposed+  -- library modules).+  -> [AssocDep] -- Inherited “internal” (main lib, named+  -- internal libs) dependencies.+  -> BuildInfo+  -> CheckM m ()+checkBuildInfo cet ams ads bi = do+  -- For the sake of clarity, we split che checks in various+  -- (top level) functions, even if we are not actually going+  -- deeper in the traversal.++  checkBuildInfoOptions (cet2bit cet) bi+  checkBuildInfoPathsContent bi+  checkBuildInfoPathsWellFormedness bi++  sv <- asksCM ccSpecVersion+  checkBuildInfoFeatures bi sv++  checkAutogenModules ams bi++  -- PVP: we check for base and all other deps.+  let ds = mergeDependencies $ targetBuildDepends bi+  (ids, rds) <-+    partitionDeps+      ads+      [mkUnqualComponentName "base"]+      ds+  let ick = const (PackageDistInexcusable BaseNoUpperBounds)+      rck = PackageDistSuspiciousWarn . MissingUpperBounds cet+      leuck = PackageDistSuspiciousWarn . LEUpperBounds cet+      tzuck = PackageDistSuspiciousWarn . TrailingZeroUpperBounds cet+      gtlck = PackageDistSuspiciousWarn . GTLowerBounds cet+  checkPVP (checkDependencyVersionRange $ not . hasUpperBound) ick ids+  unless+    (isInternalTarget cet)+    (checkPVPs (checkDependencyVersionRange $ not . hasUpperBound) rck rds)+  unless+    (isInternalTarget cet)+    (checkPVPs (checkDependencyVersionRange hasLEUpperBound) leuck ds)+  unless+    (isInternalTarget cet)+    (checkPVPs (checkDependencyVersionRange hasTrailingZeroUpperBound) tzuck ds)+  unless+    (isInternalTarget cet)+    (checkPVPs (checkDependencyVersionRange hasGTLowerBound) gtlck ds)++  -- Custom fields well-formedness (ASCII).+  mapM_ checkCustomField (customFieldsBI bi)++  -- Content.+  mapM_ (checkLocalPathExist "extra-lib-dirs" . getSymbolicPath) (extraLibDirs bi)+  mapM_+    (checkLocalPathExist "extra-lib-dirs-static" . getSymbolicPath)+    (extraLibDirsStatic bi)+  mapM_+    (checkLocalPathExist "extra-framework-dirs" . getSymbolicPath)+    (extraFrameworkDirs bi)+  mapM_ (checkLocalPathExist "include-dirs" . getSymbolicPath) (includeDirs bi)+  mapM_+    (checkLocalPathExist "hs-source-dirs" . getSymbolicPath)+    (hsSourceDirs bi)++-- Well formedness of BI contents (no `Haskell2015`, no deprecated+-- extensions etc).+checkBuildInfoPathsContent :: Monad m => BuildInfo -> CheckM m ()+checkBuildInfoPathsContent bi = do+  mapM_ checkLang (allLanguages bi)+  mapM_ checkExt (allExtensions bi)+  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)+  mapM_ checkBTDep ds+  where+    checkLang :: Monad m => Language -> CheckM m ()+    checkLang (UnknownLanguage n) =+      tellP (PackageBuildWarning (UnknownLanguages [n]))+    checkLang _ = return ()++    checkExt :: Monad m => Extension -> CheckM m ()+    checkExt (UnknownExtension n)+      | n `elem` map prettyShow knownLanguages =+          tellP (PackageBuildWarning (LanguagesAsExtension [n]))+      | otherwise =+          tellP (PackageBuildWarning (UnknownExtensions [n]))+    checkExt n = do+      let dss = filter (\(a, _) -> a == n) deprecatedExtensions+      checkP+        (not . null $ dss)+        (PackageDistSuspicious $ DeprecatedExtensions dss)++    checkIntDep :: Monad m => Dependency -> CheckM m ()+    checkIntDep d@(Dependency name vrange _) = do+      mpn <-+        asksCM+          ( packageNameToUnqualComponentName+              . pkgName+              . pnPackageId+              . ccNames+          )+      lns <- asksCM (pnSubLibs . ccNames)+      pVer <- asksCM (pkgVersion . pnPackageId . ccNames)+      let allLibNs = mpn : lns+      when+        ( mpn == packageNameToUnqualComponentName name+            -- Make sure it is not a library with the+            -- same name from another package.+            && packageNameToUnqualComponentName name `elem` allLibNs+        )+        ( checkP+            (not $ pVer `withinRange` vrange)+            (PackageBuildImpossible $ ImpossibleInternalDep [d])+        )++    checkBTDep :: Monad m => ExeDependency -> CheckM m ()+    checkBTDep ed@(ExeDependency n name vrange) = do+      exns <- asksCM (pnExecs . ccNames)+      pVer <- asksCM (pkgVersion . pnPackageId . ccNames)+      pNam <- asksCM (pkgName . pnPackageId . ccNames)+      checkP+        ( n == pNam+            && name `notElem` exns -- internal+            -- not present+        )+        (PackageBuildImpossible $ MissingInternalExe [ed])+      when+        (name `elem` exns)+        ( checkP+            (not $ pVer `withinRange` vrange)+            (PackageBuildImpossible $ ImpossibleInternalExe [ed])+        )++-- Paths well-formedness check for BuildInfo.+checkBuildInfoPathsWellFormedness :: Monad m => BuildInfo -> CheckM m ()+checkBuildInfoPathsWellFormedness bi = do+  mapM_ (checkPath False "asm-sources" PathKindFile . getSymbolicPath) (asmSources bi)+  mapM_ (checkPath False "cmm-sources" PathKindFile . getSymbolicPath) (cmmSources bi)+  mapM_ (checkPath False "c-sources" PathKindFile . getSymbolicPath) (cSources bi)+  mapM_ (checkPath False "cxx-sources" PathKindFile . getSymbolicPath) (cxxSources bi)+  mapM_ (checkPath False "js-sources" PathKindFile . getSymbolicPath) (jsSources bi)+  mapM_+    (checkPath False "install-includes" PathKindFile . getSymbolicPath)+    (installIncludes bi)+  mapM_+    (checkPath False "hs-source-dirs" PathKindDirectory . getSymbolicPath)+    (hsSourceDirs bi)+  -- Possibly absolute paths.+  mapM_ (checkPath True "includes" PathKindFile . getSymbolicPath) (includes bi)+  mapM_+    (checkPath True "include-dirs" PathKindDirectory . getSymbolicPath)+    (includeDirs bi)+  mapM_+    (checkPath True "extra-lib-dirs" PathKindDirectory . getSymbolicPath)+    (extraLibDirs bi)+  mapM_+    (checkPath True "extra-lib-dirs-static" PathKindDirectory . getSymbolicPath)+    (extraLibDirsStatic bi)+  mapM_ checkOptionPath (perCompilerFlavorToList $ options bi)+  where+    checkOptionPath+      :: Monad m+      => (CompilerFlavor, [FilePath])+      -> CheckM m ()+    checkOptionPath (GHC, paths) =+      mapM_+        ( \path ->+            checkP+              (isInsideDist path)+              (PackageDistInexcusable $ DistPoint Nothing path)+        )+        paths+    checkOptionPath _ = return ()++-- Checks for features that can be present in BuildInfo only with certain+-- CabalSpecVersion.+checkBuildInfoFeatures+  :: Monad m+  => BuildInfo+  -> CabalSpecVersion+  -> CheckM m ()+checkBuildInfoFeatures bi sv = do+  -- Default language can be used only w/ spec ≥ 1.10+  checkSpecVer+    CabalSpecV1_10+    (isJust $ defaultLanguage bi)+    (PackageBuildWarning CVDefaultLanguage)+  -- CheckSpecVer sv.+  checkDefaultLanguage+  -- Check use of 'extra-framework-dirs' field.+  checkSpecVer+    CabalSpecV1_24+    (not . null $ extraFrameworkDirs bi)+    (PackageDistSuspiciousWarn CVExtraFrameworkDirs)+  -- Check use of default-extensions field don't need to do the+  -- equivalent check for other-extensions.+  checkSpecVer+    CabalSpecV1_10+    (not . null $ defaultExtensions bi)+    (PackageBuildWarning CVDefaultExtensions)+  -- Check use of extensions field+  checkP+    (sv >= CabalSpecV1_10 && (not . null $ oldExtensions bi))+    (PackageBuildWarning CVExtensionsDeprecated)++  -- asm-sources, cmm-sources and friends only w/ spec ≥ 1.10+  checkCVSources (map getSymbolicPath $ asmSources bi)+  checkCVSources (map getSymbolicPath $ cmmSources bi)+  checkCVSources (extraBundledLibs bi)+  checkCVSources (extraLibFlavours bi)++  -- extra-dynamic-library-flavours requires ≥ 3.0+  checkSpecVer+    CabalSpecV3_0+    (not . null $ extraDynLibFlavours bi)+    (PackageDistInexcusable $ CVExtraDynamic [extraDynLibFlavours bi])+  -- virtual-modules requires ≥ 2.2+  checkSpecVer CabalSpecV2_2 (not . null $ virtualModules bi) $+    (PackageDistInexcusable CVVirtualModules)+  -- Check use of thinning and renaming.+  checkSpecVer+    CabalSpecV2_0+    (not . null $ mixins bi)+    (PackageDistInexcusable CVMixins)++  checkBuildInfoExtensions bi+  where+    checkCVSources :: Monad m => [FilePath] -> CheckM m ()+    checkCVSources cvs =+      checkSpecVer+        CabalSpecV3_0+        (not . null $ cvs)+        (PackageDistInexcusable CVSources)++    checkDefaultLanguage :: Monad m => CheckM m ()+    checkDefaultLanguage = do+      -- < 1.10 has no `default-language` field.+      when+        (sv >= CabalSpecV1_10 && isNothing (defaultLanguage bi))+        -- < 3.4 mandatory, after just a suggestion.+        ( if sv < CabalSpecV3_4+            then tellP (PackageBuildWarning CVDefaultLanguageComponent)+            else tellP (PackageDistInexcusable CVDefaultLanguageComponentSoft)+        )++-- Tests for extensions usage which can break Cabal < 1.4.+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+  -- As of Cabal-1.4 we can add new extensions without worrying+  -- about breaking old versions of cabal.+  checkSpecVer+    CabalSpecV1_2+    (not . null $ extCabal1_2)+    ( PackageDistInexcusable $+        CVExtensions CabalSpecV1_2 extCabal1_2+    )+  checkSpecVer+    CabalSpecV1_4+    (not . null $ extCabal1_4)+    ( PackageDistInexcusable $+        CVExtensions CabalSpecV1_4 extCabal1_4+    )+  where+    -- The known extensions in Cabal-1.2.3+    compatExtensions :: [Extension]+    compatExtensions =+      map+        EnableExtension+        [ OverlappingInstances+        , UndecidableInstances+        , IncoherentInstances+        , RecursiveDo+        , ParallelListComp+        , MultiParamTypeClasses+        , FunctionalDependencies+        , Rank2Types+        , RankNTypes+        , PolymorphicComponents+        , ExistentialQuantification+        , ScopedTypeVariables+        , ImplicitParams+        , FlexibleContexts+        , FlexibleInstances+        , EmptyDataDecls+        , CPP+        , BangPatterns+        , TypeSynonymInstances+        , TemplateHaskell+        , ForeignFunctionInterface+        , Arrows+        , Generics+        , NamedFieldPuns+        , PatternGuards+        , GeneralizedNewtypeDeriving+        , ExtensibleRecords+        , RestrictedTypeSynonyms+        , HereDocuments+        ]+        ++ map+          DisableExtension+          [MonomorphismRestriction, ImplicitPrelude]+        ++ compatExtensionsExtra++    -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6+    -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8)+    compatExtensionsExtra :: [Extension]+    compatExtensionsExtra =+      map+        EnableExtension+        [ KindSignatures+        , MagicHash+        , TypeFamilies+        , StandaloneDeriving+        , UnicodeSyntax+        , PatternSignatures+        , UnliftedFFITypes+        , LiberalTypeSynonyms+        , TypeOperators+        , RecordWildCards+        , RecordPuns+        , DisambiguateRecordFields+        , OverloadedStrings+        , GADTs+        , RelaxedPolyRec+        , ExtendedDefaultRules+        , UnboxedTuples+        , DeriveDataTypeable+        , ConstrainedClassMethods+        ]+        ++ map+          DisableExtension+          [MonoPatBinds]++-- Autogenerated modules (Paths_, PackageInfo_) checks. We could pass this+-- function something more specific than the whole BuildInfo, but it would be+-- a tuple of [ModuleName] lists, error prone.+checkAutogenModules+  :: Monad m+  => [ModuleName] -- Additional modules not present+  -- in BuildInfo (e.g. exposed library+  -- modules).+  -> BuildInfo+  -> CheckM m ()+checkAutogenModules ams bi = do+  pkgId <- asksCM (pnPackageId . ccNames)+  let+    -- It is an unfortunate reality that autogenPathsModuleName+    -- and autogenPackageInfoModuleName work on PackageDescription+    -- while not needing it all, but just the `package` bit.+    minimalPD = emptyPackageDescription{package = pkgId}+    autoPathsName = autogenPathsModuleName minimalPD+    autoInfoModuleName = autogenPackageInfoModuleName minimalPD++  -- Autogenerated module + some default extension build failure.+  autogenCheck autoPathsName CVAutogenPaths+  rebindableClashCheck autoPathsName RebindableClashPaths++  -- Paths_* module + some default extension build failure.+  autogenCheck autoInfoModuleName CVAutogenPackageInfo+  rebindableClashCheck autoInfoModuleName RebindableClashPackageInfo++  -- PackageInfo_* module + cabal-version < 3.12+  -- See Mikolaj’s comments on #9481 on why this has to be+  -- PackageBuildImpossible and not merely PackageDistInexcusable.+  checkSpecVer+    CabalSpecV3_12+    (elem autoInfoModuleName allModsForAuto)+    (PackageBuildImpossible CVAutogenPackageInfoGuard)+  where+    allModsForAuto :: [ModuleName]+    allModsForAuto = ams ++ otherModules bi++    autogenCheck+      :: Monad m+      => ModuleName+      -> CheckExplanation+      -> CheckM m ()+    autogenCheck name warning = do+      sv <- asksCM ccSpecVersion+      checkP+        ( sv >= CabalSpecV2_0+            && elem name allModsForAuto+            && notElem name (autogenModules bi)+        )+        (PackageDistInexcusable warning)++    rebindableClashCheck+      :: Monad m+      => ModuleName+      -> CheckExplanation+      -> CheckM m ()+    rebindableClashCheck name warning = do+      checkSpecVer+        CabalSpecV2_2+        ( ( name `elem` otherModules bi+              || name `elem` autogenModules bi+          )+            && checkExts+        )+        (PackageBuildImpossible warning)++    -- Do we have some peculiar extensions active which would interfere+    -- (cabal-version <2.2) with Paths_modules?+    checkExts :: Bool+    checkExts =+      let exts = defaultExtensions bi+       in rebind `elem` exts+            && (strings `elem` exts || lists `elem` exts)+      where+        rebind = EnableExtension RebindableSyntax+        strings = EnableExtension OverloadedStrings+        lists = EnableExtension OverloadedLists++checkLocalPathExist+  :: Monad m+  => String -- .cabal field where we found the error.+  -> FilePath+  -> CheckM m ()+checkLocalPathExist title dir =+  checkPkg+    ( \ops -> do+        dn <- not <$> doesDirectoryExist ops dir+        let rp = not (isAbsoluteOnAnyPlatform dir)+        return (rp && dn)+    )+    (PackageBuildWarning $ UnknownDirectory title dir)++-- PVP --++-- Sometimes we read (or end up with) “straddle” deps declarations+-- like this:+--+--     build-depends: base > 3, base < 4+--+-- `mergeDependencies` reduces that to base > 3 && < 4, _while_ maintaining+-- dependencies order in the list (better UX).+mergeDependencies :: [Dependency] -> [Dependency]+mergeDependencies [] = []+mergeDependencies l@(d : _) =+  let (sames, diffs) = partition ((== depName d) . depName) l+      merged =+        Dependency+          (depPkgName d)+          ( foldl intersectVersionRanges anyVersion $+              map depVerRange sames+          )+          (depLibraries d)+   in merged : mergeDependencies diffs+  where+    depName :: Dependency -> String+    depName wd = unPackageName . depPkgName $ wd++-- Is this an internal target? We do not perform PVP checks on those,+-- see https://github.com/haskell/cabal/pull/8361#issuecomment-1577547091+isInternalTarget :: CEType -> Bool+isInternalTarget (CETLibrary{}) = False+isInternalTarget (CETForeignLibrary{}) = False+isInternalTarget (CETExecutable{}) = False+isInternalTarget (CETTest{}) = True+isInternalTarget (CETBenchmark{}) = True+isInternalTarget (CETSetup{}) = False++-- ------------------------------------------------------------+-- Options+-- ------------------------------------------------------------++-- Target type for option checking.+data BITarget = BITLib | BITTestBench | BITOther+  deriving (Eq, Show)++cet2bit :: CEType -> BITarget+cet2bit (CETLibrary{}) = BITLib+cet2bit (CETForeignLibrary{}) = BITLib+cet2bit (CETExecutable{}) = BITOther+cet2bit (CETTest{}) = BITTestBench+cet2bit (CETBenchmark{}) = BITTestBench+cet2bit CETSetup = BITOther++-- General check on all options (ghc, C, C++, …) for common inaccuracies.+checkBuildInfoOptions :: Monad m => BITarget -> BuildInfo -> CheckM m ()+checkBuildInfoOptions t bi = do+  checkGHCOptions "ghc-options" t (hcOptions GHC bi)+  checkGHCOptions "ghc-prof-options" t (hcProfOptions GHC bi)+  checkGHCOptions "ghc-shared-options" t (hcSharedOptions GHC bi)+  let ldOpts = ldOptions bi+  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+  :: Monad m+  => CabalField -- .cabal field name where we found the error.+  -> BITarget -- Target type.+  -> [String] -- Options (alas in String form).+  -> CheckM m ()+checkGHCOptions title t opts = do+  checkGeneral+  case t of+    BITLib -> sequence_ [checkLib, checkNonTestBench]+    BITTestBench -> checkTestBench+    BITOther -> checkNonTestBench+  where+    checkFlags :: Monad m => [String] -> PackageCheck -> CheckM m ()+    checkFlags fs ck = checkP (any (`elem` fs) opts) ck++    checkFlagsP+      :: Monad m+      => (String -> Bool)+      -> (String -> PackageCheck)+      -> CheckM m ()+    checkFlagsP p ckc =+      case filter p opts of+        [] -> return ()+        (_ : _) -> tellP (ckc title)++    checkGeneral = do+      checkFlags+        ["-fasm"]+        (PackageDistInexcusable $ OptFasm title)+      checkFlags+        ["-fhpc"]+        (PackageDistInexcusable $ OptHpc title)+      checkFlags+        ["-prof"]+        (PackageBuildWarning $ OptProf title)+      pid <- asksCM (pnPackageId . ccNames)+      -- Scripts add the -o flag in the fake-package.cabal in order to have the+      -- executable name match the script name even when there are characters+      -- in the script name which are illegal to have as a target name.+      unless (pid == fakePackageId) $+        checkFlags+          ["-o"]+          (PackageBuildWarning $ OptO title)+      checkFlags+        ["-hide-package"]+        (PackageBuildWarning $ OptHide title)+      checkFlags+        ["--make"]+        (PackageBuildWarning $ OptMake title)+      checkFlags+        ["-O", "-O1"]+        (PackageDistInexcusable $ OptOOne title)+      checkFlags+        ["-O2"]+        (PackageDistSuspiciousWarn $ OptOTwo title)+      checkFlags+        ["-split-sections"]+        (PackageBuildWarning $ OptSplitSections title)+      checkFlags+        ["-split-objs"]+        (PackageBuildWarning $ OptSplitObjs title)+      checkFlags+        ["-optl-Wl,-s", "-optl-s"]+        (PackageDistInexcusable $ OptWls title)+      checkFlags+        ["-fglasgow-exts"]+        (PackageDistSuspicious $ OptExts title)+      let ghcNoRts = rmRtsOpts opts+      checkAlternatives+        title+        "default-extensions"+        [ (flag, prettyShow extension)+        | flag <- ghcNoRts+        , Just extension <- [ghcExtension flag]+        ]+      checkAlternatives+        title+        "default-extensions"+        [ (flag, extension)+        | flag@('-' : 'X' : extension) <- ghcNoRts+        ]+      checkAlternatives+        title+        "cpp-options"+        ( [(flag, flag) | flag@('-' : 'D' : _) <- ghcNoRts]+            ++ [(flag, flag) | flag@('-' : 'U' : _) <- ghcNoRts]+        )+      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+        title+        "extra-libraries"+        [(flag, lib) | flag@('-' : 'l' : lib) <- ghcNoRts]+      checkAlternatives+        title+        "extra-libraries-static"+        [(flag, lib) | flag@('-' : 'l' : lib) <- ghcNoRts]+      checkAlternatives+        title+        "extra-lib-dirs"+        [(flag, dir) | flag@('-' : 'L' : dir) <- ghcNoRts]+      checkAlternatives+        title+        "extra-lib-dirs-static"+        [(flag, dir) | flag@('-' : 'L' : dir) <- ghcNoRts]+      checkAlternatives+        title+        "frameworks"+        [ (flag, fmwk)+        | (flag@"-framework", fmwk) <-+            zip ghcNoRts (safeTail ghcNoRts)+        ]+      checkAlternatives+        title+        "extra-framework-dirs"+        [ (flag, dir)+        | (flag@"-framework-path", dir) <-+            zip ghcNoRts (safeTail ghcNoRts)+        ]+      -- Old `checkDevelopmentOnlyFlagsOptions` section+      checkFlags+        ["-Werror"]+        (PackageDistInexcusable $ WErrorUnneeded title)+      checkFlags+        ["-fdefer-type-errors"]+        (PackageDistInexcusable $ FDeferTypeErrorsUnneeded title)+      checkFlags+        [ "-fprof-auto"+        , "-fprof-auto-top"+        , "-fprof-auto-calls"+        , "-fprof-cafs"+        , "-fno-prof-count-entries"+        , "-auto-all"+        , "-auto"+        , "-caf-all"+        ]+        (PackageDistSuspicious $ ProfilingUnneeded title)+      checkFlagsP+        ( \opt ->+            "-d" `isPrefixOf` opt+              && opt /= "-dynamic"+        )+        (PackageDistInexcusable . DynamicUnneeded)+      checkFlagsP+        ( \opt -> case opt of+            "-j" -> True+            ('-' : 'j' : d : _) -> isDigit d+            _ -> False+        )+        (PackageDistInexcusable . JUnneeded)++    checkLib = do+      checkP+        ("-rtsopts" `elem` opts)+        (PackageBuildWarning $ OptRts title)+      checkP+        (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) opts)+        (PackageBuildWarning $ OptWithRts title)++    checkTestBench = do+      checkFlags+        ["-O0", "-Onot"]+        (PackageDistSuspiciousWarn $ OptONot title)++    checkNonTestBench = do+      checkFlags+        ["-O0", "-Onot"]+        (PackageDistSuspicious $ OptONot title)++    ghcExtension ('-' : 'f' : name) = case name of+      "allow-overlapping-instances" -> enable OverlappingInstances+      "no-allow-overlapping-instances" -> disable OverlappingInstances+      "th" -> enable TemplateHaskell+      "no-th" -> disable TemplateHaskell+      "ffi" -> enable ForeignFunctionInterface+      "no-ffi" -> disable ForeignFunctionInterface+      "fi" -> enable ForeignFunctionInterface+      "no-fi" -> disable ForeignFunctionInterface+      "monomorphism-restriction" -> enable MonomorphismRestriction+      "no-monomorphism-restriction" -> disable MonomorphismRestriction+      "mono-pat-binds" -> enable MonoPatBinds+      "no-mono-pat-binds" -> disable MonoPatBinds+      "allow-undecidable-instances" -> enable UndecidableInstances+      "no-allow-undecidable-instances" -> disable UndecidableInstances+      "allow-incoherent-instances" -> enable IncoherentInstances+      "no-allow-incoherent-instances" -> disable IncoherentInstances+      "arrows" -> enable Arrows+      "no-arrows" -> disable Arrows+      "generics" -> enable Generics+      "no-generics" -> disable Generics+      "implicit-prelude" -> enable ImplicitPrelude+      "no-implicit-prelude" -> disable ImplicitPrelude+      "implicit-params" -> enable ImplicitParams+      "no-implicit-params" -> disable ImplicitParams+      "bang-patterns" -> enable BangPatterns+      "no-bang-patterns" -> disable BangPatterns+      "scoped-type-variables" -> enable ScopedTypeVariables+      "no-scoped-type-variables" -> disable ScopedTypeVariables+      "extended-default-rules" -> enable ExtendedDefaultRules+      "no-extended-default-rules" -> disable ExtendedDefaultRules+      _ -> Nothing+    ghcExtension "-cpp" = enable CPP+    ghcExtension _ = Nothing++    enable e = Just (EnableExtension e)+    disable e = Just (DisableExtension e)++    rmRtsOpts :: [String] -> [String]+    rmRtsOpts ("-with-rtsopts" : _ : xs) = rmRtsOpts xs+    rmRtsOpts (x : xs) = x : rmRtsOpts xs+    rmRtsOpts [] = []++checkCLikeOptions+  :: Monad m+  => WarnLang -- Language we are warning about (C or C++).+  -> CabalField -- Field where we found the error.+  -> [String] -- Options in string form.+  -> [String] -- Link options in String form.+  -> CheckM m ()+checkCLikeOptions label prefix opts ldOpts = do+  checkAlternatives+    prefix+    "include-dirs"+    [(flag, dir) | flag@('-' : 'I' : dir) <- opts]+  checkAlternatives+    prefix+    "extra-libraries"+    [(flag, lib) | flag@('-' : 'l' : lib) <- opts]+  checkAlternatives+    prefix+    "extra-lib-dirs"+    [(flag, dir) | flag@('-' : 'L' : dir) <- opts]++  checkAlternatives+    "ld-options"+    "extra-libraries"+    [(flag, lib) | flag@('-' : 'l' : lib) <- ldOpts]+  checkAlternatives+    "ld-options"+    "extra-lib-dirs"+    [(flag, dir) | flag@('-' : 'L' : dir) <- ldOpts]++  checkP+    (any (`elem` ["-O", "-Os", "-O0", "-O1", "-O2", "-O3"]) opts)+    (PackageDistSuspicious $ COptONumber prefix label)++checkAlternatives+  :: Monad m+  => CabalField -- Wrong field.+  -> CabalField -- Appropriate field.+  -> [(String, String)] -- List of good and bad flags.+  -> CheckM m ()+checkAlternatives badField goodField flags = do+  let (badFlags, _) = unzip flags+  checkP+    (not $ null badFlags)+    (PackageBuildWarning $ OptAlternatives badField goodField flags)++checkCPPOptions+  :: Monad m+  => [String] -- Options in String form.+  -> CheckM m ()+checkCPPOptions opts = do+  checkAlternatives+    "cpp-options"+    "include-dirs"+    [(flag, dir) | flag@('-' : 'I' : dir) <- opts]+  mapM_+    ( \opt ->+        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
@@ -0,0 +1,1527 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      :  Distribution.PackageDescription.Check.Warning+-- Copyright   :  Francesco Ariis 2022+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Warning types, messages, severity and associated functions.+module Distribution.PackageDescription.Check.Warning+  ( -- * Types and constructors+    PackageCheck (..)+  , CheckExplanation (..)+  , CheckExplanationID+  , CheckExplanationIDString+  , CEType (..)+  , WarnLang (..)++    -- * Operations+  , ppPackageCheck+  , ppCheckExplanationId+  , isHackageDistError+  , extractCheckExplanation+  , filterPackageChecksById+  , filterPackageChecksByIdString+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.CabalSpecVersion (CabalSpecVersion, showCabalSpecVersion)+import Distribution.License (License, knownLicenses)+import Distribution.ModuleName (ModuleName)+import Distribution.Parsec.Warning (PWarning, showPWarning)+import Distribution.Pretty (prettyShow)+import Distribution.Types.BenchmarkType (BenchmarkType, knownBenchmarkTypes)+import Distribution.Types.Dependency (Dependency (..))+import Distribution.Types.ExeDependency (ExeDependency)+import Distribution.Types.Flag (FlagName, unFlagName)+import Distribution.Types.LibraryName (LibraryName (..), showLibraryName)+import Distribution.Types.PackageName (PackageName)+import Distribution.Types.TestType (TestType, knownTestTypes)+import Distribution.Types.UnqualComponentName+import Distribution.Types.Version (Version)+import Distribution.Utils.Path (FileOrDir (..), Pkg, RelativePath, getSymbolicPath)+import Language.Haskell.Extension (Extension)++import qualified Data.Either as Either+import qualified Data.List as List+import qualified Data.Set as Set++-- ------------------------------------------------------------+-- Check types and explanations+-- ------------------------------------------------------------++-- | Results of some kind of failed package check.+--+-- There are a range of severities, from merely dubious to totally insane.+-- All of them come with a human readable explanation. In future we may augment+-- them with more machine readable explanations, for example to help an IDE+-- suggest automatic corrections.+data PackageCheck+  = -- | This package description is no good. There's no way it's going to+    -- build sensibly. This should give an error at configure time.+    PackageBuildImpossible {explanation :: CheckExplanation}+  | -- | A problem that is likely to affect building the package, or an+    -- issue that we'd like every package author to be aware of, even if+    -- the package is never distributed.+    PackageBuildWarning {explanation :: CheckExplanation}+  | -- | An issue that might not be a problem for the package author but+    -- might be annoying or detrimental when the package is distributed to+    -- users. We should encourage distributed packages to be free from these+    -- issues, but occasionally there are justifiable reasons so we cannot+    -- ban them entirely.+    PackageDistSuspicious {explanation :: CheckExplanation}+  | -- | Like PackageDistSuspicious but will only display warnings+    -- rather than causing abnormal exit when you run 'cabal check'.+    PackageDistSuspiciousWarn {explanation :: CheckExplanation}+  | -- | An issue that is OK in the author's environment but is almost+    -- certain to be a portability problem for other environments. We can+    -- quite legitimately refuse to publicly distribute packages with these+    -- problems.+    PackageDistInexcusable {explanation :: CheckExplanation}+  deriving (Eq, Ord)++-- | Pretty printing 'PackageCheck'.+ppPackageCheck :: PackageCheck -> String+ppPackageCheck e =+  let ex = explanation e+   in "["+        ++ (ppCheckExplanationId . checkExplanationId) ex+        ++ "] "+        ++ ppExplanation ex++-- | Broken 'Show' instance (not bijective with Read), alas external packages+-- depend on it.+instance Show PackageCheck where+  show notice = ppPackageCheck notice++-- | Would Hackage refuse a package because of this error?+isHackageDistError :: PackageCheck -> Bool+isHackageDistError = \case+  (PackageBuildImpossible{}) -> True+  (PackageBuildWarning{}) -> True+  (PackageDistInexcusable{}) -> True+  (PackageDistSuspicious{}) -> False+  (PackageDistSuspiciousWarn{}) -> False++-- | Filter Package Check by CheckExplanationID.+filterPackageChecksById+  :: [PackageCheck]+  -- ^ Original checks.+  -> [CheckExplanationID]+  -- ^ IDs to omit.+  -> [PackageCheck]+filterPackageChecksById cs is = filter ff cs+  where+    ff :: PackageCheck -> Bool+    ff c =+      flip notElem is+        . checkExplanationId+        . extractCheckExplanation+        $ c++-- | Filter Package Check by Check explanation /string/.+filterPackageChecksByIdString+  :: [PackageCheck]+  -- ^ Original checks.+  -> [CheckExplanationIDString]+  -- ^ IDs to omit, in @String@ format.+  -> ([PackageCheck], [CheckExplanationIDString])+-- Filtered checks plus unrecognised id strings.+filterPackageChecksByIdString cs ss =+  let (es, is) = Either.partitionEithers $ map readExplanationID ss+   in (filterPackageChecksById cs is, es)++-- | Explanations of 'PackageCheck`'s errors/warnings.+data CheckExplanation+  = ParseWarning FilePath PWarning+  | NoNameField+  | NoVersionField+  | NoTarget+  | UnnamedInternal+  | DuplicateSections [UnqualComponentName]+  | IllegalLibraryName PackageName+  | NoModulesExposed LibraryName+  | SignaturesCabal2+  | AutogenNotExposed+  | AutogenIncludesNotIncluded+  | NoMainIs UnqualComponentName+  | NoHsLhsMain+  | MainCCabal1_18+  | AutogenNoOther CEType+  | AutogenIncludesNotIncludedExe+  | TestsuiteTypeNotKnown TestType+  | TestsuiteNotSupported TestType+  | BenchmarkTypeNotKnown BenchmarkType+  | BenchmarkNotSupported BenchmarkType+  | NoHsLhsMainBench+  | InvalidNameWin PackageName+  | ZPrefix+  | NoBuildType+  | NoCustomSetup+  | UnknownCompilers [String]+  | UnknownLanguages [String]+  | UnknownExtensions [String]+  | LanguagesAsExtension [String]+  | DeprecatedExtensions [(Extension, Maybe Extension)]+  | MissingFieldCategory+  | MissingFieldMaintainer+  | MissingFieldSynopsis+  | MissingFieldDescription+  | MissingFieldSynOrDesc+  | SynopsisTooLong+  | ShortDesc+  | InvalidTestWith [Dependency]+  | ImpossibleInternalDep [Dependency]+  | ImpossibleInternalExe [ExeDependency]+  | MissingInternalExe [ExeDependency]+  | NONELicense+  | NoLicense+  | AllRightsReservedLicense+  | LicenseMessParse License+  | UnrecognisedLicense String+  | UncommonBSD4+  | UnknownLicenseVersion License [Version]+  | NoLicenseFile+  | UnrecognisedSourceRepo String+  | MissingType+  | MissingLocation+  | GitProtocol+  | MissingModule+  | MissingTag+  | SubdirRelPath+  | SubdirGoodRelPath String+  | OptFasm String+  | OptHpc String+  | OptProf String+  | OptO String+  | OptHide String+  | OptMake String+  | OptONot String+  | OptOOne String+  | OptOTwo String+  | OptSplitSections String+  | OptSplitObjs String+  | OptWls String+  | OptExts String+  | OptRts String+  | OptWithRts String+  | COptONumber String WarnLang+  | COptCPP String+  | OptJSPP String+  | OptAlternatives String String [(String, String)]+  | RelativeOutside String FilePath+  | AbsolutePath String FilePath+  | BadRelativePath String FilePath String+  | DistPoint (Maybe String) FilePath+  | GlobSyntaxError String String+  | RecursiveGlobInRoot String FilePath+  | InvalidOnWin [FilePath]+  | FilePathTooLong FilePath+  | FilePathNameTooLong FilePath+  | FilePathSplitTooLong FilePath+  | FilePathEmpty+  | CVTestSuite+  | CVDefaultLanguage+  | CVDefaultLanguageComponent+  | CVDefaultLanguageComponentSoft+  | CVExtraDocFiles+  | CVMultiLib+  | CVReexported+  | CVMixins+  | CVExtraFrameworkDirs+  | CVDefaultExtensions+  | CVExtensionsDeprecated+  | CVSources+  | CVExtraDynamic [[String]]+  | CVVirtualModules+  | CVSourceRepository+  | CVExtensions CabalSpecVersion [Extension]+  | CVCustomSetup+  | CVExpliticDepsCustomSetup+  | CVAutogenPaths+  | CVAutogenPackageInfo+  | CVAutogenPackageInfoGuard+  | GlobNoMatch String String+  | GlobExactMatch String String FilePath+  | GlobNoDir String String FilePath+  | UnknownOS [String]+  | UnknownArch [String]+  | UnknownCompiler [String]+  | BaseNoUpperBounds+  | MissingUpperBounds CEType [String]+  | LEUpperBounds CEType [String]+  | TrailingZeroUpperBounds CEType [String]+  | GTLowerBounds CEType [String]+  | SuspiciousFlagName [String]+  | DeclaredUsedFlags (Set.Set FlagName) (Set.Set FlagName)+  | NonASCIICustomField [String]+  | RebindableClashPaths+  | RebindableClashPackageInfo+  | WErrorUnneeded String+  | JUnneeded String+  | FDeferTypeErrorsUnneeded String+  | DynamicUnneeded String+  | ProfilingUnneeded String+  | UpperBoundSetup String+  | DuplicateModule String [ModuleName]+  | PotentialDupModule String [ModuleName]+  | BOMStart FilePath+  | NotPackageName FilePath String+  | NoDesc+  | MultiDesc [String]+  | UnknownFile String (RelativePath Pkg File)+  | MissingSetupFile+  | MissingConfigureScript+  | UnknownDirectory String FilePath+  | MissingSourceControl+  | MissingExpectedDocFiles Bool [FilePath]+  | WrongFieldForExpectedDocFiles Bool String [FilePath]+  deriving (Eq, Ord, Show)++-- TODO Some checks have a constructor in list form+--      (e.g. `SomeWarn [n]`), CheckM m () correctly catches warnings in+--      different stanzas in different checks (so it is not one soup).+--+--      Ideally [SomeWar [a], SomeWar [b]] would be translated into+--      SomeWar [a,b] in the few cases where it is appropriate for UX+--      and left separated otherwise.+--      To achieve this the Writer part of CheckM could be modified+--      to be a ad hoc monoid.++-- Convenience.+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 specific 'CheckExplanation'. This ensures `--ignore`+-- can output a warning on unrecognised values.+-- ☞ N.B.: should be kept in sync with 'CheckExplanation'.+data CheckExplanationID+  = CIParseWarning+  | CINoNameField+  | CINoVersionField+  | CINoTarget+  | CIUnnamedInternal+  | CIDuplicateSections+  | CIIllegalLibraryName+  | CINoModulesExposed+  | CISignaturesCabal2+  | CIAutogenNotExposed+  | CIAutogenIncludesNotIncluded+  | CINoMainIs+  | CINoHsLhsMain+  | CIMainCCabal1_18+  | CIAutogenNoOther+  | CIAutogenIncludesNotIncludedExe+  | CITestsuiteTypeNotKnown+  | CITestsuiteNotSupported+  | CIBenchmarkTypeNotKnown+  | CIBenchmarkNotSupported+  | CINoHsLhsMainBench+  | CIInvalidNameWin+  | CIZPrefix+  | CINoBuildType+  | CINoCustomSetup+  | CIUnknownCompilers+  | CIUnknownLanguages+  | CIUnknownExtensions+  | CILanguagesAsExtension+  | CIDeprecatedExtensions+  | CIMissingFieldCategory+  | CIMissingFieldMaintainer+  | CIMissingFieldSynopsis+  | CIMissingFieldDescription+  | CIMissingFieldSynOrDesc+  | CISynopsisTooLong+  | CIShortDesc+  | CIInvalidTestWith+  | CIImpossibleInternalDep+  | CIImpossibleInternalExe+  | CIMissingInternalExe+  | CINONELicense+  | CINoLicense+  | CIAllRightsReservedLicense+  | CILicenseMessParse+  | CIUnrecognisedLicense+  | CIUncommonBSD4+  | CIUnknownLicenseVersion+  | CINoLicenseFile+  | CIUnrecognisedSourceRepo+  | CIMissingType+  | CIMissingLocation+  | CIGitProtocol+  | CIMissingModule+  | CIMissingTag+  | CISubdirRelPath+  | CISubdirGoodRelPath+  | CIOptFasm+  | CIOptHpc+  | CIOptProf+  | CIOptO+  | CIOptHide+  | CIOptMake+  | CIOptONot+  | CIOptOOne+  | CIOptOTwo+  | CIOptSplitSections+  | CIOptSplitObjs+  | CIOptWls+  | CIOptExts+  | CIOptRts+  | CIOptWithRts+  | CICOptONumber+  | CICOptCPP+  | CIOptJSPP+  | CIOptAlternatives+  | CIRelativeOutside+  | CIAbsolutePath+  | CIBadRelativePath+  | CIDistPoint+  | CIGlobSyntaxError+  | CIRecursiveGlobInRoot+  | CIInvalidOnWin+  | CIFilePathTooLong+  | CIFilePathNameTooLong+  | CIFilePathSplitTooLong+  | CIFilePathEmpty+  | CICVTestSuite+  | CICVDefaultLanguage+  | CICVDefaultLanguageComponent+  | CICVDefaultLanguageComponentSoft+  | CICVExtraDocFiles+  | CICVMultiLib+  | CICVReexported+  | CICVMixins+  | CICVExtraFrameworkDirs+  | CICVDefaultExtensions+  | CICVExtensionsDeprecated+  | CICVSources+  | CICVExtraDynamic+  | CICVVirtualModules+  | CICVSourceRepository+  | CICVExtensions+  | CICVCustomSetup+  | CICVExpliticDepsCustomSetup+  | CICVAutogenPaths+  | CICVAutogenPackageInfo+  | CICVAutogenPackageInfoGuard+  | CIGlobNoMatch+  | CIGlobExactMatch+  | CIGlobNoDir+  | CIUnknownOS+  | CIUnknownArch+  | CIUnknownCompiler+  | CIBaseNoUpperBounds+  | CIMissingUpperBounds+  | CILEUpperBounds+  | CITrailingZeroUpperBounds+  | CIGTLowerBounds+  | CISuspiciousFlagName+  | CIDeclaredUsedFlags+  | CINonASCIICustomField+  | CIRebindableClashPaths+  | CIRebindableClashPackageInfo+  | CIWErrorUnneeded+  | CIJUnneeded+  | CIFDeferTypeErrorsUnneeded+  | CIDynamicUnneeded+  | CIProfilingUnneeded+  | CIUpperBoundSetup+  | CIDuplicateModule+  | CIPotentialDupModule+  | CIBOMStart+  | CINotPackageName+  | CINoDesc+  | CIMultiDesc+  | CIUnknownFile+  | CIMissingSetupFile+  | CIMissingConfigureScript+  | CIUnknownDirectory+  | CIMissingSourceControl+  | CIMissingExpectedDocFiles+  | CIWrongFieldForExpectedDocFiles+  deriving (Eq, Ord, Show, Enum, Bounded)++checkExplanationId :: CheckExplanation -> CheckExplanationID+checkExplanationId (ParseWarning{}) = CIParseWarning+checkExplanationId (NoNameField{}) = CINoNameField+checkExplanationId (NoVersionField{}) = CINoVersionField+checkExplanationId (NoTarget{}) = CINoTarget+checkExplanationId (UnnamedInternal{}) = CIUnnamedInternal+checkExplanationId (DuplicateSections{}) = CIDuplicateSections+checkExplanationId (IllegalLibraryName{}) = CIIllegalLibraryName+checkExplanationId (NoModulesExposed{}) = CINoModulesExposed+checkExplanationId (SignaturesCabal2{}) = CISignaturesCabal2+checkExplanationId (AutogenNotExposed{}) = CIAutogenNotExposed+checkExplanationId (AutogenIncludesNotIncluded{}) = CIAutogenIncludesNotIncluded+checkExplanationId (NoMainIs{}) = CINoMainIs+checkExplanationId (NoHsLhsMain{}) = CINoHsLhsMain+checkExplanationId (MainCCabal1_18{}) = CIMainCCabal1_18+checkExplanationId (AutogenNoOther{}) = CIAutogenNoOther+checkExplanationId (AutogenIncludesNotIncludedExe{}) = CIAutogenIncludesNotIncludedExe+checkExplanationId (TestsuiteTypeNotKnown{}) = CITestsuiteTypeNotKnown+checkExplanationId (TestsuiteNotSupported{}) = CITestsuiteNotSupported+checkExplanationId (BenchmarkTypeNotKnown{}) = CIBenchmarkTypeNotKnown+checkExplanationId (BenchmarkNotSupported{}) = CIBenchmarkNotSupported+checkExplanationId (NoHsLhsMainBench{}) = CINoHsLhsMainBench+checkExplanationId (InvalidNameWin{}) = CIInvalidNameWin+checkExplanationId (ZPrefix{}) = CIZPrefix+checkExplanationId (NoBuildType{}) = CINoBuildType+checkExplanationId (NoCustomSetup{}) = CINoCustomSetup+checkExplanationId (UnknownCompilers{}) = CIUnknownCompilers+checkExplanationId (UnknownLanguages{}) = CIUnknownLanguages+checkExplanationId (UnknownExtensions{}) = CIUnknownExtensions+checkExplanationId (LanguagesAsExtension{}) = CILanguagesAsExtension+checkExplanationId (DeprecatedExtensions{}) = CIDeprecatedExtensions+checkExplanationId (MissingFieldCategory{}) = CIMissingFieldCategory+checkExplanationId (MissingFieldMaintainer{}) = CIMissingFieldMaintainer+checkExplanationId (MissingFieldSynopsis{}) = CIMissingFieldSynopsis+checkExplanationId (MissingFieldDescription{}) = CIMissingFieldDescription+checkExplanationId (MissingFieldSynOrDesc{}) = CIMissingFieldSynOrDesc+checkExplanationId (SynopsisTooLong{}) = CISynopsisTooLong+checkExplanationId (ShortDesc{}) = CIShortDesc+checkExplanationId (InvalidTestWith{}) = CIInvalidTestWith+checkExplanationId (ImpossibleInternalDep{}) = CIImpossibleInternalDep+checkExplanationId (ImpossibleInternalExe{}) = CIImpossibleInternalExe+checkExplanationId (MissingInternalExe{}) = CIMissingInternalExe+checkExplanationId (NONELicense{}) = CINONELicense+checkExplanationId (NoLicense{}) = CINoLicense+checkExplanationId (AllRightsReservedLicense{}) = CIAllRightsReservedLicense+checkExplanationId (LicenseMessParse{}) = CILicenseMessParse+checkExplanationId (UnrecognisedLicense{}) = CIUnrecognisedLicense+checkExplanationId (UncommonBSD4{}) = CIUncommonBSD4+checkExplanationId (UnknownLicenseVersion{}) = CIUnknownLicenseVersion+checkExplanationId (NoLicenseFile{}) = CINoLicenseFile+checkExplanationId (UnrecognisedSourceRepo{}) = CIUnrecognisedSourceRepo+checkExplanationId (MissingType{}) = CIMissingType+checkExplanationId (MissingLocation{}) = CIMissingLocation+checkExplanationId (GitProtocol{}) = CIGitProtocol+checkExplanationId (MissingModule{}) = CIMissingModule+checkExplanationId (MissingTag{}) = CIMissingTag+checkExplanationId (SubdirRelPath{}) = CISubdirRelPath+checkExplanationId (SubdirGoodRelPath{}) = CISubdirGoodRelPath+checkExplanationId (OptFasm{}) = CIOptFasm+checkExplanationId (OptHpc{}) = CIOptHpc+checkExplanationId (OptProf{}) = CIOptProf+checkExplanationId (OptO{}) = CIOptO+checkExplanationId (OptHide{}) = CIOptHide+checkExplanationId (OptMake{}) = CIOptMake+checkExplanationId (OptONot{}) = CIOptONot+checkExplanationId (OptOOne{}) = CIOptOOne+checkExplanationId (OptOTwo{}) = CIOptOTwo+checkExplanationId (OptSplitSections{}) = CIOptSplitSections+checkExplanationId (OptSplitObjs{}) = CIOptSplitObjs+checkExplanationId (OptWls{}) = CIOptWls+checkExplanationId (OptExts{}) = CIOptExts+checkExplanationId (OptRts{}) = CIOptRts+checkExplanationId (OptWithRts{}) = CIOptWithRts+checkExplanationId (COptONumber{}) = CICOptONumber+checkExplanationId (COptCPP{}) = CICOptCPP+checkExplanationId (OptJSPP{}) = CIOptJSPP+checkExplanationId (OptAlternatives{}) = CIOptAlternatives+checkExplanationId (RelativeOutside{}) = CIRelativeOutside+checkExplanationId (AbsolutePath{}) = CIAbsolutePath+checkExplanationId (BadRelativePath{}) = CIBadRelativePath+checkExplanationId (DistPoint{}) = CIDistPoint+checkExplanationId (GlobSyntaxError{}) = CIGlobSyntaxError+checkExplanationId (RecursiveGlobInRoot{}) = CIRecursiveGlobInRoot+checkExplanationId (InvalidOnWin{}) = CIInvalidOnWin+checkExplanationId (FilePathTooLong{}) = CIFilePathTooLong+checkExplanationId (FilePathNameTooLong{}) = CIFilePathNameTooLong+checkExplanationId (FilePathSplitTooLong{}) = CIFilePathSplitTooLong+checkExplanationId (FilePathEmpty{}) = CIFilePathEmpty+checkExplanationId (CVTestSuite{}) = CICVTestSuite+checkExplanationId (CVDefaultLanguage{}) = CICVDefaultLanguage+checkExplanationId (CVDefaultLanguageComponent{}) = CICVDefaultLanguageComponent+checkExplanationId (CVDefaultLanguageComponentSoft{}) = CICVDefaultLanguageComponentSoft+checkExplanationId (CVExtraDocFiles{}) = CICVExtraDocFiles+checkExplanationId (CVMultiLib{}) = CICVMultiLib+checkExplanationId (CVReexported{}) = CICVReexported+checkExplanationId (CVMixins{}) = CICVMixins+checkExplanationId (CVExtraFrameworkDirs{}) = CICVExtraFrameworkDirs+checkExplanationId (CVDefaultExtensions{}) = CICVDefaultExtensions+checkExplanationId (CVExtensionsDeprecated{}) = CICVExtensionsDeprecated+checkExplanationId (CVSources{}) = CICVSources+checkExplanationId (CVExtraDynamic{}) = CICVExtraDynamic+checkExplanationId (CVVirtualModules{}) = CICVVirtualModules+checkExplanationId (CVSourceRepository{}) = CICVSourceRepository+checkExplanationId (CVExtensions{}) = CICVExtensions+checkExplanationId (CVCustomSetup{}) = CICVCustomSetup+checkExplanationId (CVExpliticDepsCustomSetup{}) = CICVExpliticDepsCustomSetup+checkExplanationId (CVAutogenPaths{}) = CICVAutogenPaths+checkExplanationId (CVAutogenPackageInfo{}) = CICVAutogenPackageInfo+checkExplanationId (CVAutogenPackageInfoGuard{}) = CICVAutogenPackageInfoGuard+checkExplanationId (GlobNoMatch{}) = CIGlobNoMatch+checkExplanationId (GlobExactMatch{}) = CIGlobExactMatch+checkExplanationId (GlobNoDir{}) = CIGlobNoDir+checkExplanationId (UnknownOS{}) = CIUnknownOS+checkExplanationId (UnknownArch{}) = CIUnknownArch+checkExplanationId (UnknownCompiler{}) = CIUnknownCompiler+checkExplanationId (BaseNoUpperBounds{}) = CIBaseNoUpperBounds+checkExplanationId (MissingUpperBounds{}) = CIMissingUpperBounds+checkExplanationId (LEUpperBounds{}) = CILEUpperBounds+checkExplanationId (TrailingZeroUpperBounds{}) = CITrailingZeroUpperBounds+checkExplanationId (GTLowerBounds{}) = CIGTLowerBounds+checkExplanationId (SuspiciousFlagName{}) = CISuspiciousFlagName+checkExplanationId (DeclaredUsedFlags{}) = CIDeclaredUsedFlags+checkExplanationId (NonASCIICustomField{}) = CINonASCIICustomField+checkExplanationId (RebindableClashPaths{}) = CIRebindableClashPaths+checkExplanationId (RebindableClashPackageInfo{}) = CIRebindableClashPackageInfo+checkExplanationId (WErrorUnneeded{}) = CIWErrorUnneeded+checkExplanationId (JUnneeded{}) = CIJUnneeded+checkExplanationId (FDeferTypeErrorsUnneeded{}) = CIFDeferTypeErrorsUnneeded+checkExplanationId (DynamicUnneeded{}) = CIDynamicUnneeded+checkExplanationId (ProfilingUnneeded{}) = CIProfilingUnneeded+checkExplanationId (UpperBoundSetup{}) = CIUpperBoundSetup+checkExplanationId (DuplicateModule{}) = CIDuplicateModule+checkExplanationId (PotentialDupModule{}) = CIPotentialDupModule+checkExplanationId (BOMStart{}) = CIBOMStart+checkExplanationId (NotPackageName{}) = CINotPackageName+checkExplanationId (NoDesc{}) = CINoDesc+checkExplanationId (MultiDesc{}) = CIMultiDesc+checkExplanationId (UnknownFile{}) = CIUnknownFile+checkExplanationId (MissingSetupFile{}) = CIMissingSetupFile+checkExplanationId (MissingConfigureScript{}) = CIMissingConfigureScript+checkExplanationId (UnknownDirectory{}) = CIUnknownDirectory+checkExplanationId (MissingSourceControl{}) = CIMissingSourceControl+checkExplanationId (MissingExpectedDocFiles{}) = CIMissingExpectedDocFiles+checkExplanationId (WrongFieldForExpectedDocFiles{}) = CIWrongFieldForExpectedDocFiles++type CheckExplanationIDString = String++-- | A one-word identifier for each @CheckExplanation@.+ppCheckExplanationId :: CheckExplanationID -> CheckExplanationIDString+-- NOTE: If you modify anything here, remember to change the documentation+-- in @doc/cabal-commands.rst@!+-- NOTE: These strings will have to satisfy a test that these messages don't+-- have too many dashes:+--   $ cabal run Cabal-tests:unit-tests -- --pattern=Parsimonious+ppCheckExplanationId CIParseWarning = "parser-warning"+ppCheckExplanationId CINoNameField = "no-name-field"+ppCheckExplanationId CINoVersionField = "no-version-field"+ppCheckExplanationId CINoTarget = "no-target"+ppCheckExplanationId CIUnnamedInternal = "unnamed-internal-library"+ppCheckExplanationId CIDuplicateSections = "duplicate-sections"+ppCheckExplanationId CIIllegalLibraryName = "illegal-library-name"+ppCheckExplanationId CINoModulesExposed = "no-modules-exposed"+ppCheckExplanationId CISignaturesCabal2 = "signatures"+ppCheckExplanationId CIAutogenNotExposed = "autogen-not-exposed"+ppCheckExplanationId CIAutogenIncludesNotIncluded = "autogen-not-included"+ppCheckExplanationId CINoMainIs = "no-main-is"+ppCheckExplanationId CINoHsLhsMain = "unknown-extension-main"+ppCheckExplanationId CIMainCCabal1_18 = "c-like-main"+ppCheckExplanationId CIAutogenNoOther = "autogen-other-modules"+ppCheckExplanationId CIAutogenIncludesNotIncludedExe = "autogen-exe"+ppCheckExplanationId CITestsuiteTypeNotKnown = "unknown-testsuite-type"+ppCheckExplanationId CITestsuiteNotSupported = "unsupported-testsuite"+ppCheckExplanationId CIBenchmarkTypeNotKnown = "unknown-bench"+ppCheckExplanationId CIBenchmarkNotSupported = "unsupported-bench"+ppCheckExplanationId CINoHsLhsMainBench = "bench-unknown-extension"+ppCheckExplanationId CIInvalidNameWin = "invalid-name-win"+ppCheckExplanationId CIZPrefix = "reserved-z-prefix"+ppCheckExplanationId CINoBuildType = "no-build-type"+ppCheckExplanationId CINoCustomSetup = "undeclared-custom-setup"+ppCheckExplanationId CIUnknownCompilers = "unknown-compiler-tested"+ppCheckExplanationId CIUnknownLanguages = "unknown-languages"+ppCheckExplanationId CIUnknownExtensions = "unknown-extension"+ppCheckExplanationId CILanguagesAsExtension = "languages-as-extensions"+ppCheckExplanationId CIDeprecatedExtensions = "deprecated-extensions"+ppCheckExplanationId CIMissingFieldCategory = "no-category"+ppCheckExplanationId CIMissingFieldMaintainer = "no-maintainer"+ppCheckExplanationId CIMissingFieldSynopsis = "no-synopsis"+ppCheckExplanationId CIMissingFieldDescription = "no-description"+ppCheckExplanationId CIMissingFieldSynOrDesc = "no-syn-desc"+ppCheckExplanationId CISynopsisTooLong = "long-synopsis"+ppCheckExplanationId CIShortDesc = "short-description"+ppCheckExplanationId CIInvalidTestWith = "invalid-range-tested"+ppCheckExplanationId CIImpossibleInternalDep = "impossible-dep"+ppCheckExplanationId CIImpossibleInternalExe = "impossible-dep-exe"+ppCheckExplanationId CIMissingInternalExe = "no-internal-exe"+ppCheckExplanationId CINONELicense = "license-none"+ppCheckExplanationId CINoLicense = "no-license"+ppCheckExplanationId CIAllRightsReservedLicense = "all-rights-reserved"+ppCheckExplanationId CILicenseMessParse = "license-parse"+ppCheckExplanationId CIUnrecognisedLicense = "unknown-license"+ppCheckExplanationId CIUncommonBSD4 = "bsd4-license"+ppCheckExplanationId CIUnknownLicenseVersion = "unknown-license-version"+ppCheckExplanationId CINoLicenseFile = "no-license-file"+ppCheckExplanationId CIUnrecognisedSourceRepo = "unrecognised-repo-type"+ppCheckExplanationId CIMissingType = "repo-no-type"+ppCheckExplanationId CIMissingLocation = "repo-no-location"+ppCheckExplanationId CIGitProtocol = "git-protocol"+ppCheckExplanationId CIMissingModule = "repo-no-module"+ppCheckExplanationId CIMissingTag = "repo-no-tag"+ppCheckExplanationId CISubdirRelPath = "repo-relative-dir"+ppCheckExplanationId CISubdirGoodRelPath = "repo-malformed-subdir"+ppCheckExplanationId CIOptFasm = "option-fasm"+ppCheckExplanationId CIOptHpc = "option-fhpc"+ppCheckExplanationId CIOptProf = "option-prof"+ppCheckExplanationId CIOptO = "option-o"+ppCheckExplanationId CIOptHide = "option-hide-package"+ppCheckExplanationId CIOptMake = "option-make"+ppCheckExplanationId CIOptONot = "option-optimize"+ppCheckExplanationId CIOptOOne = "option-o1"+ppCheckExplanationId CIOptOTwo = "option-o2"+ppCheckExplanationId CIOptSplitSections = "option-split-section"+ppCheckExplanationId CIOptSplitObjs = "option-split-objs"+ppCheckExplanationId CIOptWls = "option-optl-wl"+ppCheckExplanationId CIOptExts = "use-extension"+ppCheckExplanationId CIOptRts = "option-rtsopts"+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"+ppCheckExplanationId CIBadRelativePath = "malformed-relative-path"+ppCheckExplanationId CIDistPoint = "unreliable-dist-path"+ppCheckExplanationId CIGlobSyntaxError = "glob-syntax-error"+ppCheckExplanationId CIRecursiveGlobInRoot = "recursive-glob"+ppCheckExplanationId CIInvalidOnWin = "invalid-path-win"+ppCheckExplanationId CIFilePathTooLong = "long-path"+ppCheckExplanationId CIFilePathNameTooLong = "long-name"+ppCheckExplanationId CIFilePathSplitTooLong = "name-not-portable"+ppCheckExplanationId CIFilePathEmpty = "empty-path"+ppCheckExplanationId CICVTestSuite = "test-cabal-ver"+ppCheckExplanationId CICVDefaultLanguage = "default-language"+ppCheckExplanationId CICVDefaultLanguageComponent = "no-default-language"+ppCheckExplanationId CICVDefaultLanguageComponentSoft = "add-language"+ppCheckExplanationId CICVExtraDocFiles = "extra-doc-files"+ppCheckExplanationId CICVMultiLib = "multilib"+ppCheckExplanationId CICVReexported = "reexported-modules"+ppCheckExplanationId CICVMixins = "mixins"+ppCheckExplanationId CICVExtraFrameworkDirs = "extra-framework-dirs"+ppCheckExplanationId CICVDefaultExtensions = "default-extensions"+ppCheckExplanationId CICVExtensionsDeprecated = "extensions-field"+ppCheckExplanationId CICVSources = "unsupported-sources"+ppCheckExplanationId CICVExtraDynamic = "extra-dynamic"+ppCheckExplanationId CICVVirtualModules = "virtual-modules"+ppCheckExplanationId CICVSourceRepository = "source-repository"+ppCheckExplanationId CICVExtensions = "incompatible-extension"+ppCheckExplanationId CICVCustomSetup = "no-setup-depends"+ppCheckExplanationId CICVExpliticDepsCustomSetup = "dependencies-setup"+ppCheckExplanationId CICVAutogenPaths = "no-autogen-paths"+ppCheckExplanationId CICVAutogenPackageInfo = "no-autogen-pinfo"+ppCheckExplanationId CICVAutogenPackageInfoGuard = "autogen-guard"+ppCheckExplanationId CIGlobNoMatch = "no-glob-match"+ppCheckExplanationId CIGlobExactMatch = "glob-no-extension"+ppCheckExplanationId CIGlobNoDir = "glob-missing-dir"+ppCheckExplanationId CIUnknownOS = "unknown-os"+ppCheckExplanationId CIUnknownArch = "unknown-arch"+ppCheckExplanationId CIUnknownCompiler = "unknown-compiler"+ppCheckExplanationId CIBaseNoUpperBounds = "missing-bounds-important"+ppCheckExplanationId CIMissingUpperBounds = "missing-upper-bounds"+ppCheckExplanationId CILEUpperBounds = "le-upper-bounds"+ppCheckExplanationId CITrailingZeroUpperBounds = "tz-upper-bounds"+ppCheckExplanationId CIGTLowerBounds = "gt-lower-bounds"+ppCheckExplanationId CISuspiciousFlagName = "suspicious-flag"+ppCheckExplanationId CIDeclaredUsedFlags = "unused-flag"+ppCheckExplanationId CINonASCIICustomField = "non-ascii"+ppCheckExplanationId CIRebindableClashPaths = "rebindable-clash-paths"+ppCheckExplanationId CIRebindableClashPackageInfo = "rebindable-clash-info"+ppCheckExplanationId CIWErrorUnneeded = "werror"+ppCheckExplanationId CIJUnneeded = "unneeded-j"+ppCheckExplanationId CIFDeferTypeErrorsUnneeded = "fdefer-type-errors"+ppCheckExplanationId CIDynamicUnneeded = "debug-flag"+ppCheckExplanationId CIProfilingUnneeded = "fprof-flag"+ppCheckExplanationId CIUpperBoundSetup = "missing-bounds-setup"+ppCheckExplanationId CIDuplicateModule = "duplicate-modules"+ppCheckExplanationId CIPotentialDupModule = "maybe-duplicate-modules"+ppCheckExplanationId CIBOMStart = "bom"+ppCheckExplanationId CINotPackageName = "name-no-match"+ppCheckExplanationId CINoDesc = "no-cabal-file"+ppCheckExplanationId CIMultiDesc = "multiple-cabal-file"+ppCheckExplanationId CIUnknownFile = "unknown-file"+ppCheckExplanationId CIMissingSetupFile = "missing-setup"+ppCheckExplanationId CIMissingConfigureScript = "missing-conf-script"+ppCheckExplanationId CIUnknownDirectory = "unknown-directory"+ppCheckExplanationId CIMissingSourceControl = "no-repository"+ppCheckExplanationId CIMissingExpectedDocFiles = "no-docs"+ppCheckExplanationId CIWrongFieldForExpectedDocFiles = "doc-place"++-- String: the unrecognised 'CheckExplanationIDString' itself.+readExplanationID+  :: CheckExplanationIDString+  -> Either String CheckExplanationID+readExplanationID s = maybe (Left s) Right (lookup s idsDict)+  where+    idsDict :: [(CheckExplanationIDString, CheckExplanationID)]+    idsDict = map (\i -> (ppCheckExplanationId i, i)) [minBound .. maxBound]++-- | Which stanza does `CheckExplanation` refer to?+data CEType+  = CETLibrary LibraryName+  | CETForeignLibrary UnqualComponentName+  | CETExecutable UnqualComponentName+  | CETTest UnqualComponentName+  | CETBenchmark UnqualComponentName+  | CETSetup+  deriving (Eq, Ord, Show)++-- | Pretty printing `CEType`.+ppCET :: CEType -> String+ppCET cet = case cet of+  CETLibrary ln -> showLibraryName ln+  CETForeignLibrary n -> "foreign library" ++ qn n+  CETExecutable n -> "executable" ++ qn n+  CETTest n -> "test suite" ++ qn n+  CETBenchmark n -> "benchmark" ++ qn n+  CETSetup -> "custom-setup"+  where+    qn :: UnqualComponentName -> String+    qn wn = (" " ++) . quote . prettyShow $ wn++-- | Which language are we referring to in our warning message?+data WarnLang = LangC | LangCPlusPlus+  deriving (Eq, Ord, Show)++-- | Pretty printing `WarnLang`.+ppWarnLang :: WarnLang -> String+ppWarnLang LangC = "C"+ppWarnLang LangCPlusPlus = "C++"++-- | Pretty printing `CheckExplanation`.+ppExplanation :: CheckExplanation -> String+ppExplanation (ParseWarning fp pp) = showPWarning fp pp+ppExplanation NoNameField = "No 'name' field."+ppExplanation NoVersionField = "No 'version' field."+ppExplanation NoTarget =+  "No executables, libraries, tests, or benchmarks found. Nothing to do."+ppExplanation UnnamedInternal =+  "Found one or more unnamed internal libraries. Only the non-internal"+    ++ " library can have the same name as the package."+ppExplanation (DuplicateSections duplicateNames) =+  "Duplicate sections: "+    ++ commaSep (map unUnqualComponentName duplicateNames)+    ++ ". The name of every library, executable, test suite,"+    ++ " and benchmark section in the package must be unique."+ppExplanation (IllegalLibraryName pname) =+  "Illegal internal library name "+    ++ prettyShow pname+    ++ ". Internal libraries cannot have the same name as the package."+    ++ " Maybe you wanted a non-internal library?"+    ++ " If so, rewrite the section stanza"+    ++ " from 'library: '"+    ++ prettyShow pname+    ++ "' to 'library'."+ppExplanation (NoModulesExposed lName) =+  showLibraryName lName ++ " does not expose any modules"+ppExplanation SignaturesCabal2 =+  "To use the 'signatures' field the package needs to specify "+    ++ "at least 'cabal-version: 2.0'."+ppExplanation AutogenNotExposed =+  "An 'autogen-module' is neither on 'exposed-modules' nor 'other-modules'."+ppExplanation AutogenIncludesNotIncluded =+  "An include in 'autogen-includes' is neither in 'includes' nor "+    ++ "'install-includes'."+ppExplanation (NoMainIs eName) =+  "No 'main-is' field found for executable " ++ prettyShow eName+ppExplanation NoHsLhsMain =+  "The 'main-is' field must specify a '.hs' or '.lhs' file "+    ++ "(even if it is generated by a preprocessor), "+    ++ "or it may specify a C/C++/obj-C source file."+ppExplanation MainCCabal1_18 =+  "The package uses a C/C++/obj-C source file for the 'main-is' field. "+    ++ "To use this feature you need to specify 'cabal-version: 1.18' or"+    ++ " higher."+ppExplanation (AutogenNoOther ct) =+  "On "+    ++ ppCET ct+    ++ " an 'autogen-module'"+    ++ " is not on 'other-modules'"+ppExplanation AutogenIncludesNotIncludedExe =+  "An include in 'autogen-includes' is not in 'includes'."+ppExplanation (TestsuiteTypeNotKnown tt) =+  quote (prettyShow tt)+    ++ " is not a known type of test suite. "+    ++ "Either remove the 'type' field or use a known type. "+    ++ "The known test suite types are: "+    ++ commaSep (map prettyShow knownTestTypes)+ppExplanation (TestsuiteNotSupported tt) =+  quote (prettyShow tt)+    ++ " is not a supported test suite version. "+    ++ "Either remove the 'type' field or use a known type. "+    ++ "The known test suite types are: "+    ++ commaSep (map prettyShow knownTestTypes)+ppExplanation (BenchmarkTypeNotKnown tt) =+  quote (prettyShow tt)+    ++ " is not a known type of benchmark. "+    ++ "Either remove the 'type' field or use a known type. "+    ++ "The known benchmark types are: "+    ++ commaSep (map prettyShow knownBenchmarkTypes)+ppExplanation (BenchmarkNotSupported tt) =+  quote (prettyShow tt)+    ++ " is not a supported benchmark version. "+    ++ "Either remove the 'type' field or use a known type. "+    ++ "The known benchmark types are: "+    ++ commaSep (map prettyShow knownBenchmarkTypes)+ppExplanation NoHsLhsMainBench =+  "The 'main-is' field must specify a '.hs' or '.lhs' file "+    ++ "(even if it is generated by a preprocessor)."+ppExplanation (InvalidNameWin pkg) =+  "The package name '"+    ++ prettyShow pkg+    ++ "' is "+    ++ "invalid on Windows. Many tools need to convert package names to "+    ++ "file names, so using this name would cause problems."+ppExplanation ZPrefix =+  "Package names with the prefix 'z-' are reserved by Cabal and "+    ++ "cannot be used."+ppExplanation NoBuildType =+  "No 'build-type' specified. If you do not need a custom Setup.hs or "+    ++ "./configure script then use 'build-type: Simple'."+ppExplanation NoCustomSetup =+  "Ignoring the 'custom-setup' section because the 'build-type' is "+    ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a "+    ++ "custom Setup.hs script."+ppExplanation (UnknownCompilers unknownCompilers) =+  "Unknown compiler "+    ++ commaSep (map quote unknownCompilers)+    ++ " in 'tested-with' field."+ppExplanation (UnknownLanguages unknownLanguages) =+  "Unknown languages: " ++ commaSep unknownLanguages+ppExplanation (UnknownExtensions unknownExtensions) =+  "Unknown extensions: " ++ commaSep unknownExtensions+ppExplanation (LanguagesAsExtension languagesUsedAsExtensions) =+  "Languages listed as extensions: "+    ++ commaSep languagesUsedAsExtensions+    ++ ". Languages must be specified in either the 'default-language' "+    ++ " or the 'other-languages' field."+ppExplanation (DeprecatedExtensions ourDeprecatedExtensions) =+  "Deprecated extensions: "+    ++ commaSep (map (quote . prettyShow . fst) ourDeprecatedExtensions)+    ++ ". "+    ++ unwords+      [ "Instead of '"+        ++ prettyShow ext+        ++ "' use '"+        ++ prettyShow replacement+        ++ "'."+      | (ext, Just replacement) <- ourDeprecatedExtensions+      ]+ppExplanation MissingFieldCategory = "No 'category' field."+ppExplanation MissingFieldMaintainer = "No 'maintainer' field."+ppExplanation MissingFieldSynopsis = "No 'synopsis' field."+ppExplanation MissingFieldDescription = "No 'description' field."+ppExplanation MissingFieldSynOrDesc = "No 'synopsis' or 'description' field."+ppExplanation SynopsisTooLong =+  "The 'synopsis' field is rather long (max 80 chars is recommended)."+ppExplanation ShortDesc =+  "The 'description' field should be longer than the 'synopsis' field. "+    ++ "It's useful to provide an informative 'description' to allow "+    ++ "Haskell programmers who have never heard about your package to "+    ++ "understand the purpose of your package. "+    ++ "The 'description' field content is typically shown by tooling "+    ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which "+    ++ "serves as a headline. "+    ++ "Please refer to <https://cabal.readthedocs.io/en/stable/"+    ++ "cabal-package.html#package-properties> for more details."+ppExplanation (InvalidTestWith testedWithImpossibleRanges) =+  "Invalid 'tested-with' version range: "+    ++ commaSep (map prettyShow testedWithImpossibleRanges)+    ++ ". To indicate that you have tested a package with multiple "+    ++ "different versions of the same compiler use multiple entries, "+    ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not "+    ++ "'tested-with: GHC==6.10.4 && ==6.12.3'."+ppExplanation (ImpossibleInternalDep depInternalLibWithImpossibleVersion) =+  "The package has an impossible version range for a dependency on an "+    ++ "internal library: "+    ++ commaSep (map prettyShow depInternalLibWithImpossibleVersion)+    ++ ". This version range does not include the current package, and must "+    ++ "be removed as the current package's library will always be used."+ppExplanation (ImpossibleInternalExe depInternalExecWithImpossibleVersion) =+  "The package has an impossible version range for a dependency on an "+    ++ "internal executable: "+    ++ commaSep (map prettyShow depInternalExecWithImpossibleVersion)+    ++ ". This version range does not include the current package, and must "+    ++ "be removed as the current package's executable will always be used."+ppExplanation (MissingInternalExe depInternalExeWithImpossibleVersion) =+  "The package depends on a missing internal executable: "+    ++ commaSep (map prettyShow depInternalExeWithImpossibleVersion)+ppExplanation NONELicense = "The 'license' field is missing or is NONE."+ppExplanation NoLicense = "The 'license' field is missing."+ppExplanation AllRightsReservedLicense =+  "The 'license' is AllRightsReserved. Is that really what you want?"+ppExplanation (LicenseMessParse lic) =+  "Unfortunately the license "+    ++ quote (prettyShow lic)+    ++ " messes up the parser in earlier Cabal versions so you need to "+    ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "+    ++ "compatibility with earlier Cabal versions then use 'OtherLicense'."+ppExplanation (UnrecognisedLicense l) =+  quote ("license: " ++ l)+    ++ " is not a recognised license. The "+    ++ "known licenses are: "+    ++ commaSep (map prettyShow knownLicenses)+ppExplanation UncommonBSD4 =+  "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' "+    ++ "refers to the old 4-clause BSD license with the advertising "+    ++ "clause. 'BSD3' refers the new 3-clause BSD license."+ppExplanation (UnknownLicenseVersion lic known) =+  "'license: "+    ++ prettyShow lic+    ++ "' is not a known "+    ++ "version of that license. The known versions are "+    ++ commaSep (map prettyShow known)+    ++ ". If this is not a mistake and you think it should be a known "+    ++ "version then please file a ticket."+ppExplanation NoLicenseFile = "A 'license-file' is not specified."+ppExplanation (UnrecognisedSourceRepo kind) =+  quote kind+    ++ " is not a recognised kind of source-repository. "+    ++ "The repo kind is usually 'head' or 'this'"+ppExplanation MissingType =+  "The source-repository 'type' is a required field."+ppExplanation MissingLocation =+  "The source-repository 'location' is a required field."+ppExplanation GitProtocol =+  "Cloning over git:// might lead to an arbitrary code execution "+    ++ "vulnerability. Furthermore, popular forges like GitHub do "+    ++ "not support it. Use https:// or ssh:// instead."+ppExplanation MissingModule =+  "For a CVS source-repository, the 'module' is a required field."+ppExplanation MissingTag =+  "For the 'this' kind of source-repository, the 'tag' is a required "+    ++ "field. It should specify the tag corresponding to this version "+    ++ "or release of the package."+ppExplanation SubdirRelPath =+  "The 'subdir' field of a source-repository must be a relative path."+ppExplanation (SubdirGoodRelPath err) =+  "The 'subdir' field of a source-repository is not a good relative path: "+    ++ show err+ppExplanation (OptFasm fieldName) =+  "'"+    ++ fieldName+    ++ ": -fasm' is unnecessary and will not work on CPU "+    ++ "architectures other than x86, x86-64, ppc or sparc."+ppExplanation (OptHpc fieldName) =+  "'"+    ++ fieldName+    ++ ": -fhpc' is not necessary. Use the configure flag "+    ++ " --enable-coverage instead."+ppExplanation (OptProf fieldName) =+  "'"+    ++ fieldName+    ++ ": -prof' is not necessary and will lead to problems "+    ++ "when used on a library. Use the configure flag "+    ++ "--enable-library-profiling and/or --enable-profiling."+ppExplanation (OptO fieldName) =+  "'"+    ++ fieldName+    ++ ": -o' is not needed. "+    ++ "The output files are named automatically."+ppExplanation (OptHide fieldName) =+  "'"+    ++ fieldName+    ++ ": -hide-package' is never needed. "+    ++ "Cabal hides all packages."+ppExplanation (OptMake fieldName) =+  "'"+    ++ fieldName+    ++ ": --make' is never needed. Cabal uses this automatically."+ppExplanation (OptONot fieldName) =+  "'"+    ++ fieldName+    ++ ": -O0' is not needed. "+    ++ "Use the --disable-optimization configure flag."+ppExplanation (OptOOne fieldName) =+  "'"+    ++ fieldName+    ++ ": -O' is not needed. "+    ++ "Cabal automatically adds the '-O' flag. "+    ++ "Setting it yourself interferes with the --disable-optimization flag."+ppExplanation (OptOTwo fieldName) =+  "'"+    ++ fieldName+    ++ ": -O2' is rarely needed. "+    ++ "Check that it is giving a real benefit "+    ++ "and not just imposing longer compile times on your users."+ppExplanation (OptSplitSections fieldName) =+  "'"+    ++ fieldName+    ++ ": -split-sections' is not needed. "+    ++ "Use the --enable-split-sections configure flag."+ppExplanation (OptSplitObjs fieldName) =+  "'"+    ++ fieldName+    ++ ": -split-objs' is not needed. "+    ++ "Use the --enable-split-objs configure flag."+ppExplanation (OptWls fieldName) =+  "'"+    ++ fieldName+    ++ ": -optl-Wl,-s' is not needed and is not portable to"+    ++ " all operating systems. Cabal 1.4 and later automatically strip"+    ++ " executables. Cabal also has a flag --disable-executable-stripping"+    ++ " which is necessary when building packages for some Linux"+    ++ " distributions and using '-optl-Wl,-s' prevents that from working."+ppExplanation (OptExts fieldName) =+  "Instead of '"+    ++ fieldName+    ++ ": -fglasgow-exts' it is preferable to use "+    ++ "the 'extensions' field."+ppExplanation (OptRts fieldName) =+  "'"+    ++ fieldName+    ++ ": -rtsopts' has no effect for libraries. It should "+    ++ "only be used for executables."+ppExplanation (OptWithRts fieldName) =+  "'"+    ++ fieldName+    ++ ": -with-rtsopts' has no effect for libraries. It "+    ++ "should only be used for executables."+ppExplanation (COptONumber prefix label) =+  "'"+    ++ prefix+    ++ ": -O[n]' is generally not needed. When building with "+    ++ " optimisations Cabal automatically adds '-O2' for "+    ++ ppWarnLang label+    ++ " code. Setting it yourself interferes with the"+    ++ " --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)+    ++ " use "+    ++ quote (goodField ++ ": " ++ unwords goodFlags)+  where+    (badFlags, goodFlags) = unzip flags+ppExplanation (RelativeOutside field path) =+  quote (field ++ ": " ++ path)+    ++ " is a relative path outside of the source tree. "+    ++ "This will not work when generating a tarball with 'sdist'."+ppExplanation (AbsolutePath field path) =+  quote (field ++ ": " ++ path)+    ++ " specifies an absolute path, but the "+    ++ quote field+    ++ " field must use relative paths."+ppExplanation (BadRelativePath field path err) =+  quote (field ++ ": " ++ path)+    ++ " is not a good relative path: "+    ++ show err+ppExplanation (DistPoint mfield path) =+  incipit+    ++ " points inside the 'dist' "+    ++ "directory. This is not reliable because the location of this "+    ++ "directory is configurable by the user (or package manager). In "+    ++ "addition, the layout of the 'dist' directory is subject to change "+    ++ "in future versions of Cabal."+  where+    -- mfiled Nothing -> the path is inside `ghc-options`+    incipit =+      maybe+        ("'ghc-options' path " ++ quote path)+        (\field -> quote (field ++ ": " ++ path))+        mfield+ppExplanation (GlobSyntaxError field expl) =+  "In the '" ++ field ++ "' field: " ++ expl+ppExplanation (RecursiveGlobInRoot field glob) =+  "In the '"+    ++ field+    ++ "': glob '"+    ++ glob+    ++ "' starts at project root directory, this might "+    ++ "include `.git/`, ``dist-newstyle/``, or other large directories!"+ppExplanation (InvalidOnWin paths) =+  "The "+    ++ quotes paths+    ++ " invalid on Windows, which "+    ++ "would cause portability problems for this package. Windows file "+    ++ "names cannot contain any of the characters \":*?<>|\", and there "+    ++ "are a few reserved names including \"aux\", \"nul\", \"con\", "+    ++ "\"prn\", \"com{1-9}\", \"lpt{1-9}\" and \"clock$\"."+  where+    quotes [failed] = "path " ++ quote failed ++ " is"+    quotes failed =+      "paths "+        ++ commaSep (map quote failed)+        ++ " are"+ppExplanation (FilePathTooLong path) =+  "The following file name is too long to store in a portable POSIX "+    ++ "format tar archive. The maximum length is 255 ASCII characters.\n"+    ++ "The file in question is:\n  "+    ++ path+ppExplanation (FilePathNameTooLong path) =+  "The following file name is too long to store in a portable POSIX "+    ++ "format tar archive. The maximum length for the name part (including "+    ++ "extension) is 100 ASCII characters. The maximum length for any "+    ++ "individual directory component is 155.\n"+    ++ "The file in question is:\n  "+    ++ path+ppExplanation (FilePathSplitTooLong path) =+  "The following file name is too long to store in a portable POSIX "+    ++ "format tar archive. While the total length is less than 255 ASCII "+    ++ "characters, there are unfortunately further restrictions. It has to "+    ++ "be possible to split the file path on a directory separator into "+    ++ "two parts such that the first part fits in 155 characters or less "+    ++ "and the second part fits in 100 characters or less. Basically you "+    ++ "have to make the file name or directory names shorter, or you could "+    ++ "split a long directory name into nested subdirectories with shorter "+    ++ "names.\nThe file in question is:\n  "+    ++ path+ppExplanation FilePathEmpty =+  "Encountered a file with an empty name, something is very wrong! "+    ++ "Files with an empty name cannot be stored in a tar archive or in "+    ++ "standard file systems."+ppExplanation CVTestSuite =+  "The 'test-suite' section is new in Cabal 1.10. "+    ++ "Unfortunately it messes up the parser in older Cabal versions "+    ++ "so you must specify at least 'cabal-version: >= 1.8', but note "+    ++ "that only Cabal 1.10 and later can actually run such test suites."+ppExplanation CVDefaultLanguage =+  "To use the 'default-language' field the package needs to specify "+    ++ "at least 'cabal-version: >= 1.10'."+ppExplanation CVDefaultLanguageComponent =+  "Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' "+    ++ "must specify the 'default-language' field for each component (e.g. "+    ++ "Haskell98 or Haskell2010). If a component uses different languages "+    ++ "in different modules then list the other ones in the "+    ++ "'other-languages' field."+ppExplanation CVDefaultLanguageComponentSoft =+  "Without `default-language`, cabal will default to Haskell98, which is "+    ++ "probably not what you want. Please add `default-language` to all "+    ++ "targets."+ppExplanation CVExtraDocFiles =+  "To use the 'extra-doc-files' field the package needs to specify "+    ++ "'cabal-version: 1.18' or higher."+ppExplanation CVMultiLib =+  "To use multiple 'library' sections or a named library section "+    ++ "the package needs to specify at least 'cabal-version: 2.0'."+ppExplanation CVReexported =+  "To use the 'reexported-module' field the package needs to specify "+    ++ "'cabal-version: 1.22' or higher."+ppExplanation CVMixins =+  "To use the 'mixins' field the package needs to specify "+    ++ "at least 'cabal-version: 2.0'."+ppExplanation CVExtraFrameworkDirs =+  "To use the 'extra-framework-dirs' field the package needs to specify"+    ++ " 'cabal-version: 1.24' or higher."+ppExplanation CVDefaultExtensions =+  "To use the 'default-extensions' field the package needs to specify "+    ++ "at least 'cabal-version: >= 1.10'."+ppExplanation CVExtensionsDeprecated =+  "For packages using 'cabal-version: >= 1.10' the 'extensions' "+    ++ "field is deprecated. The new 'default-extensions' field lists "+    ++ "extensions that are used in all modules in the component, while "+    ++ "the 'other-extensions' field lists extensions that are used in "+    ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma."+ppExplanation CVSources =+  "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' "+    ++ " and 'extra-library-flavours' requires the package "+    ++ " to specify at least 'cabal-version: 3.0'."+ppExplanation (CVExtraDynamic flavs) =+  "The use of 'extra-dynamic-library-flavours' requires the package "+    ++ " to specify at least 'cabal-version: 3.0'. The flavours are: "+    ++ commaSep (concat flavs)+ppExplanation CVVirtualModules =+  "The use of 'virtual-modules' requires the package "+    ++ " to specify at least 'cabal-version: 2.2'."+ppExplanation CVSourceRepository =+  "The 'source-repository' section is new in Cabal 1.6. "+    ++ "Unfortunately it messes up the parser in earlier Cabal versions "+    ++ "so you need to specify 'cabal-version: >= 1.6'."+ppExplanation (CVExtensions version extCab12) =+  "Unfortunately the language extensions "+    ++ commaSep (map (quote . prettyShow) extCab12)+    ++ " break the parser in earlier Cabal versions so you need to "+    ++ "specify 'cabal-version: >= "+    ++ showCabalSpecVersion version+    ++ "'. Alternatively if you require compatibility with earlier "+    ++ "Cabal versions then you may be able to use an equivalent "+    ++ "compiler-specific flag."+ppExplanation CVCustomSetup =+  "Packages using 'cabal-version: 1.24' or higher with 'build-type: Custom' "+    ++ "must use a 'custom-setup' section with a 'setup-depends' field "+    ++ "that specifies the dependencies of the Setup.hs script itself. "+    ++ "The 'setup-depends' field uses the same syntax as 'build-depends', "+    ++ "so a simple example would be 'setup-depends: base, Cabal'."+ppExplanation CVExpliticDepsCustomSetup =+  "From version 1.24 cabal supports specifying explicit dependencies "+    ++ "for Custom setup scripts. Consider using 'cabal-version: 1.24' or "+    ++ "higher and adding a 'custom-setup' section with a 'setup-depends' "+    ++ "field that specifies the dependencies of the Setup.hs script "+    ++ "itself. The 'setup-depends' field uses the same syntax as "+    ++ "'build-depends', so a simple example would be 'setup-depends: base, "+    ++ "Cabal'."+ppExplanation CVAutogenPaths =+  "Packages using 'cabal-version: 2.0' and the autogenerated "+    ++ "module Paths_* must include it also on the 'autogen-modules' field "+    ++ "besides 'exposed-modules' and 'other-modules'. This specifies that "+    ++ "the module does not come with the package and is generated on "+    ++ "setup. Modules built with a custom Setup.hs script also go here "+    ++ "to ensure that commands like sdist don't fail."+ppExplanation CVAutogenPackageInfo =+  "Packages using 'cabal-version: 2.0' and the autogenerated "+    ++ "module PackageInfo_* must include it in 'autogen-modules' as well as"+    ++ " 'exposed-modules' and 'other-modules'. This specifies that "+    ++ "the module does not come with the package and is generated on "+    ++ "setup. Modules built with a custom Setup.hs script also go here "+    ++ "to ensure that commands like sdist don't fail."+ppExplanation CVAutogenPackageInfoGuard =+  "To use the autogenerated module PackageInfo_* you need to specify "+    ++ "`cabal-version: 3.12` or higher."+ppExplanation (GlobNoMatch field glob) =+  "In '"+    ++ field+    ++ "': the pattern '"+    ++ glob+    ++ "' does not"+    ++ " match any files."+ppExplanation (GlobExactMatch field glob file) =+  "In '"+    ++ field+    ++ "': the pattern '"+    ++ glob+    ++ "' does not"+    ++ " match the file '"+    ++ file+    ++ "' because the extensions do not"+    ++ " exactly match (e.g., foo.en.html does not exactly match *.html)."+    ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or"+    ++ " higher."+ppExplanation (GlobNoDir field glob dir) =+  "In '"+    ++ field+    ++ "': the pattern '"+    ++ glob+    ++ "' attempts to"+    ++ " match files in the directory '"+    ++ dir+    ++ "', but there is no"+    ++ " directory by that name."+ppExplanation (UnknownOS unknownOSs) =+  "Unknown operating system name " ++ commaSep (map quote unknownOSs)+ppExplanation (UnknownArch unknownArches) =+  "Unknown architecture name " ++ commaSep (map quote unknownArches)+ppExplanation (UnknownCompiler unknownImpls) =+  "Unknown compiler name " ++ commaSep (map quote unknownImpls)+ppExplanation BaseNoUpperBounds =+  "The dependency 'build-depends: base' does not specify an upper "+    ++ "bound on the version number. Each major release of the 'base' "+    ++ "package changes the API in various ways and most packages will "+    ++ "need some changes to compile with it. The recommended practice "+    ++ "is to specify an upper bound on the version of the 'base' "+    ++ "package. This ensures your package will continue to build when a "+    ++ "new major version of the 'base' package is released. If you are "+    ++ "not sure what upper bound to use then use the next  major "+    ++ "version. For example if you have tested your package with 'base' "+    ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'."+ppExplanation (MissingUpperBounds ct names) =+  "On "+    ++ ppCET ct+    ++ ", "+    ++ "these packages miss upper bounds:"+    ++ listSep names+    ++ "Please add them. There is more information at https://pvp.haskell.org/"+ppExplanation (LEUpperBounds ct names) =+  "On "+    ++ ppCET ct+    ++ ", "+    ++ "these packages have less than or equals (<=) upper bounds:"+    ++ listSep names+    ++ "Please use less than (<) for upper bounds."+ppExplanation (TrailingZeroUpperBounds ct names) =+  "On "+    ++ ppCET ct+    ++ ", "+    ++ "these packages have upper bounds with trailing zeros:"+    ++ listSep names+    ++ "Please avoid trailing zeros for upper bounds."+ppExplanation (GTLowerBounds ct names) =+  "On "+    ++ ppCET ct+    ++ ", "+    ++ "these packages have greater than (>) lower bounds:"+    ++ listSep names+    ++ "Please use greater than or equals (>=) for lower bounds."+ppExplanation (SuspiciousFlagName invalidFlagNames) =+  "Suspicious flag names: "+    ++ unwords invalidFlagNames+    ++ ". "+    ++ "To avoid ambiguity in command line interfaces, a flag shouldn't "+    ++ "start with a dash. Also for better compatibility, flag names "+    ++ "shouldn't contain non-ascii characters."+ppExplanation (DeclaredUsedFlags declared used) =+  "Declared and used flag sets differ: "+    ++ s declared+    ++ " /= "+    ++ s used+    ++ ". "+  where+    s :: Set.Set FlagName -> String+    s = commaSep . map unFlagName . Set.toList+ppExplanation (NonASCIICustomField nonAsciiXFields) =+  "Non ascii custom fields: "+    ++ unwords nonAsciiXFields+    ++ ". "+    ++ "For better compatibility, custom field names "+    ++ "shouldn't contain non-ascii characters."+ppExplanation RebindableClashPaths =+  "Packages using RebindableSyntax with OverloadedStrings or"+    ++ " OverloadedLists in default-extensions, in conjunction with the"+    ++ " autogenerated module Paths_*, are known to cause compile failures"+    ++ " with Cabal < 2.2. To use these default-extensions with a Paths_*"+    ++ " autogen module, specify at least 'cabal-version: 2.2'."+ppExplanation RebindableClashPackageInfo =+  "Packages using RebindableSyntax with OverloadedStrings or"+    ++ " OverloadedLists in default-extensions, in conjunction with the"+    ++ " autogenerated module PackageInfo_*, are known to cause compile failures"+    ++ " with Cabal < 2.2. To use these default-extensions with a PackageInfo_*"+    ++ " autogen module, specify at least 'cabal-version: 2.2'."+ppExplanation (WErrorUnneeded fieldName) =+  addConditionalExp $+    "'"+      ++ fieldName+      ++ ": -Werror' makes the package easy to "+      ++ "break with future GHC versions because new GHC versions often "+      ++ "add new warnings."+ppExplanation (JUnneeded fieldName) =+  addConditionalExp $+    "'"+      ++ fieldName+      ++ ": -j[N]' can make sense for a particular user's setup,"+      ++ " but it is not appropriate for a distributed package."+ppExplanation (FDeferTypeErrorsUnneeded fieldName) =+  addConditionalExp $+    "'"+      ++ fieldName+      ++ ": -fdefer-type-errors' is fine during development "+      ++ "but is not appropriate for a distributed package."+ppExplanation (DynamicUnneeded fieldName) =+  addConditionalExp $+    "'"+      ++ fieldName+      ++ ": -d*' debug flags are not appropriate "+      ++ "for a distributed package."+ppExplanation (ProfilingUnneeded fieldName) =+  addConditionalExp $+    "'"+      ++ fieldName+      ++ ": -fprof*' profiling flags are typically not "+      ++ "appropriate for a distributed library package. These flags are "+      ++ "useful to profile this package, but when profiling other packages "+      ++ "that use this one these flags clutter the profile output with "+      ++ "excessive detail. If you think other packages really want to see "+      ++ "cost centres from this package then use '-fprof-auto-exported' "+      ++ "which puts cost centres only on exported functions."+ppExplanation (UpperBoundSetup nm) =+  "The dependency 'setup-depends: '"+    ++ nm+    ++ "' does not specify an "+    ++ "upper bound on the version number. Each major release of the "+    ++ "'"+    ++ nm+    ++ "' package changes the API in various ways and most "+    ++ "packages will need some changes to compile with it. If you are "+    ++ "not sure what upper bound to use then use the next major "+    ++ "version."+ppExplanation (DuplicateModule s dupLibsLax) =+  "Duplicate modules in "+    ++ s+    ++ ": "+    ++ commaSep (map prettyShow dupLibsLax)+ppExplanation (PotentialDupModule s dupLibsStrict) =+  "Potential duplicate modules (subject to conditionals) in "+    ++ s+    ++ ": "+    ++ commaSep (map prettyShow dupLibsStrict)+ppExplanation (BOMStart pdfile) =+  pdfile+    ++ " starts with an Unicode byte order mark (BOM)."+    ++ " This may cause problems with older cabal versions."+ppExplanation (NotPackageName pdfile expectedCabalname) =+  "The filename "+    ++ quote pdfile+    ++ " does not match package name "+    ++ "(expected: "+    ++ quote expectedCabalname+    ++ ")"+ppExplanation NoDesc =+  "No cabal file found.\n"+    ++ "Please create a package description file <pkgname>.cabal"+ppExplanation (MultiDesc multiple) =+  "Multiple cabal files found while checking.\n"+    ++ "Please use only one of: "+    ++ commaSep multiple+ppExplanation (UnknownFile fieldname file) =+  "The '"+    ++ fieldname+    ++ "' field refers to the file "+    ++ quote (getSymbolicPath file)+    ++ " which does not exist."+ppExplanation MissingSetupFile =+  "The package is missing a Setup.hs or Setup.lhs script."+ppExplanation MissingConfigureScript =+  "The 'build-type' is 'Configure' but there is no 'configure' script. "+    ++ "You probably need to run 'autoreconf -i' to generate it."+ppExplanation (UnknownDirectory kind dir) =+  quote (kind ++ ": " ++ dir)+    ++ " specifies a directory which does not exist."+ppExplanation MissingSourceControl =+  "When distributing packages, it is encouraged to specify source "+    ++ "control information in the .cabal file using one or more "+    ++ "'source-repository' sections. See the Cabal user guide for "+    ++ "details."+ppExplanation (MissingExpectedDocFiles extraDocFileSupport paths) =+  "Please consider including the "+    ++ quotes paths+    ++ " in the '"+    ++ targetField+    ++ "' section of the .cabal file "+    ++ "if it contains useful information for users of the package."+  where+    quotes [p] = "file " ++ quote p+    quotes ps = "files " ++ commaSep (map quote ps)+    targetField =+      if extraDocFileSupport+        then "extra-doc-files"+        else "extra-source-files"+ppExplanation (WrongFieldForExpectedDocFiles extraDocFileSupport field paths) =+  "Please consider moving the "+    ++ quotes paths+    ++ " from the '"+    ++ field+    ++ "' section of the .cabal file "+    ++ "to the section '"+    ++ targetField+    ++ "'."+  where+    quotes [p] = "file " ++ quote p+    quotes ps = "files " ++ commaSep (map quote ps)+    targetField =+      if extraDocFileSupport+        then "extra-doc-files"+        else "extra-source-files"++-- * Formatting utilities++listSep :: [String] -> String+listSep names =+  let separator = "\n  - "+   in separator ++ List.intercalate separator names ++ "\n"++commaSep :: [String] -> String+commaSep = List.intercalate ", "++quote :: String -> String+quote s = "'" ++ s ++ "'"++addConditionalExp :: String -> String+addConditionalExp expl =+  expl+    ++ " Alternatively, if you want to use this, make it conditional based "+    ++ "on a Cabal configuration flag (with 'manual: True' and 'default: "+    ++ "False') and enable that flag during development."
− src/Distribution/PackageDescription/Configuration.hs 
@@ -1,600 +0,0 @@--- -fno-warn-deprecations for use of Map.foldWithKey-{-# OPTIONS_GHC -fno-warn-deprecations #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription.Configuration--- Copyright   :  Thomas Schilling, 2007--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This is about the cabal configurations feature. It exports--- 'finalizePD' and 'flattenPackageDescription' which are--- functions for converting 'GenericPackageDescription's down to--- 'PackageDescription's. It has code for working with the tree of conditions--- and resolving or flattening conditions.--module Distribution.PackageDescription.Configuration (-    finalizePD,-    flattenPackageDescription,--    -- Utils-    parseCondition,-    freeVars,-    extractCondition,-    extractConditions,-    addBuildableCondition,-    mapCondTree,-    mapTreeData,-    mapTreeConds,-    mapTreeConstrs,-    transformAllBuildInfos,-    transformAllBuildDepends,-    transformAllBuildDependsN,-  ) where--import Distribution.Compat.Prelude-import Prelude ()---- lens-import qualified Distribution.Types.BuildInfo.Lens                 as L-import qualified Distribution.Types.GenericPackageDescription.Lens as L-import qualified Distribution.Types.PackageDescription.Lens        as L-import qualified Distribution.Types.SetupBuildInfo.Lens            as L--import           Distribution.Compat.CharParsing             hiding (char)-import qualified Distribution.Compat.CharParsing             as P-import           Distribution.Compat.Lens-import           Distribution.Compiler-import           Distribution.PackageDescription-import           Distribution.PackageDescription.Utils-import           Distribution.Parsec-import           Distribution.Pretty-import           Distribution.Simple.Utils-import           Distribution.System-import           Distribution.Types.Component-import Distribution.Utils.Path-import           Distribution.Types.ComponentRequestedSpec-import           Distribution.Types.DependencyMap-import           Distribution.Types.PackageVersionConstraint-import           Distribution.Version--import qualified Data.Map.Lazy as Map-import           Data.Tree     (Tree (Node))------------------------------------------------------------------------------------ | Simplify a configuration condition using the OS and arch names.  Returns---   the names of all the flags occurring in the condition.-simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar-                      -> (Condition FlagName, [FlagName])-simplifyWithSysParams os arch cinfo cond = (cond', flags)-  where-    (cond', flags) = simplifyCondition cond interp-    interp (OS os')    = Right $ os' == os-    interp (Arch arch') = Right $ arch' == arch-    interp (Impl comp vr)-      | matchImpl (compilerInfoId cinfo) = Right True-      | otherwise = case compilerInfoCompat cinfo of-          -- fixme: treat Nothing as unknown, rather than empty list once we-          --        support partial resolution of system parameters-          Nothing     -> Right False-          Just compat -> Right (any matchImpl compat)-          where-            matchImpl (CompilerId c v) = comp == c && v `withinRange` vr-    interp (PackageFlag f) = Left f---- TODO: Add instances and check------ prop_sC_idempotent cond a o = cond' == cond''---   where---     cond'  = simplifyCondition cond a o---     cond'' = simplifyCondition cond' a o------ prop_sC_noLits cond a o = isLit res || not (hasLits res)---   where---     res = simplifyCondition cond a o---     hasLits (Lit _) = True---     hasLits (CNot c) = hasLits c---     hasLits (COr l r) = hasLits l || hasLits r---     hasLits (CAnd l r) = hasLits l || hasLits r---     hasLits _ = False------- | Parse a configuration condition from a string.-parseCondition :: CabalParsing m => m (Condition ConfVar)-parseCondition = condOr-  where-    condOr   = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr-    condAnd  = sepByNonEmpty cond (oper "&&")>>= return . foldl1 CAnd-    -- TODO: try?-    cond     = sp >> (boolLiteral <|> inparens condOr <|> notCond <|> osCond-                      <|> archCond <|> flagCond <|> implCond )-    inparens   = between (P.char '(' >> sp) (sp >> P.char ')' >> sp)-    notCond  = P.char '!' >> sp >> cond >>= return . CNot-    osCond   = string "os" >> sp >> inparens osIdent >>= return . Var-    archCond = string "arch" >> sp >> inparens archIdent >>= return . Var-    flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var-    implCond = string "impl" >> sp >> inparens implIdent >>= return . Var-    boolLiteral   = fmap Lit  parsec-    archIdent     = fmap Arch parsec-    osIdent       = fmap OS   parsec-    flagIdent     = fmap (PackageFlag . mkFlagName . lowercase) (munch1 isIdentChar)-    isIdentChar c = isAlphaNum c || c == '_' || c == '-'-    oper s        = sp >> string s >> sp-    sp            = spaces-    implIdent     = do i <- parsec-                       vr <- sp >> option anyVersion parsec-                       return $ Impl i vr------------------------------------------------------------------------------------ | Result of dependency test. Isomorphic to @Maybe d@ but renamed for---   clarity.-data DepTestRslt d = DepOk | MissingDeps d--instance Semigroup d => Monoid (DepTestRslt d) where-    mempty = DepOk-    mappend = (<>)--instance Semigroup d => Semigroup (DepTestRslt d) where-    DepOk <> x     = x-    x     <> DepOk = x-    (MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d')----- | Try to find a flag assignment that satisfies the constraints of all trees.------ Returns either the missing dependencies, or a tuple containing the--- resulting data, the associated dependencies, and the chosen flag--- assignments.------ In case of failure, the union of the dependencies that led to backtracking--- on all branches is returned.--- [TODO: Could also be specified with a function argument.]------ TODO: The current algorithm is rather naive.  A better approach would be to:------ * Rule out possible paths, by taking a look at the associated dependencies.------ * Infer the required values for the conditions of these paths, and---   calculate the required domains for the variables used in these---   conditions.  Then picking a flag assignment would be linear (I guess).------ This would require some sort of SAT solving, though, thus it's not--- implemented unless we really need it.----resolveWithFlags ::-     [(FlagName,[Bool])]-        -- ^ Domain for each flag name, will be tested in order.-  -> ComponentRequestedSpec-  -> OS      -- ^ OS as returned by Distribution.System.buildOS-  -> Arch    -- ^ Arch as returned by Distribution.System.buildArch-  -> CompilerInfo  -- ^ Compiler information-  -> [PackageVersionConstraint]  -- ^ Additional constraints-  -> [CondTree ConfVar [Dependency] PDTagged]-  -> ([Dependency] -> DepTestRslt [Dependency])  -- ^ Dependency test function.-  -> Either [Dependency] (TargetSet PDTagged, FlagAssignment)-       -- ^ Either the missing dependencies (error case), or a pair of-       -- (set of build targets with dependencies, chosen flag assignments)-resolveWithFlags dom enabled os arch impl constrs trees checkDeps =-    either (Left . fromDepMapUnion) Right $ explore (build mempty dom)-  where-    -- simplify trees by (partially) evaluating all conditions and converting-    -- dependencies to dependency maps.-    simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged]-    simplifiedTrees = map ( mapTreeConstrs toDepMap  -- convert to maps-                          . addBuildableConditionPDTagged-                          . mapTreeConds (fst . simplifyWithSysParams os arch impl))-                          trees--    -- @explore@ searches a tree of assignments, backtracking whenever a flag-    -- introduces a dependency that cannot be satisfied.  If there is no-    -- solution, @explore@ returns the union of all dependencies that caused-    -- it to backtrack.  Since the tree is constructed lazily, we avoid some-    -- computation overhead in the successful case.-    explore :: Tree FlagAssignment-            -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment)-    explore (Node flags ts) =-        let targetSet = TargetSet $ flip map simplifiedTrees $-                -- apply additional constraints to all dependencies-                first (`constrainBy` constrs) .-                simplifyCondTree (env flags)-            deps = overallDependencies enabled targetSet-        in case checkDeps (fromDepMap deps) of-             DepOk | null ts   -> Right (targetSet, flags)-                   | otherwise -> tryAll $ map explore ts-             MissingDeps mds   -> Left (toDepMapUnion mds)--    -- Builds a tree of all possible flag assignments.  Internal nodes-    -- have only partial assignments.-    build :: FlagAssignment -> [(FlagName, [Bool])] -> Tree FlagAssignment-    build assigned [] = Node assigned []-    build assigned ((fn, vals) : unassigned) =-        Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals--    tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a-    tryAll = foldr mp mz--    -- special version of `mplus' for our local purposes-    mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a-    mp m@(Right _) _           = m-    mp _           m@(Right _) = m-    mp (Left xs)   (Left ys)   = Left (xs <> ys)--    -- `mzero'-    mz :: Either DepMapUnion a-    mz = Left (DepMapUnion Map.empty)--    env :: FlagAssignment -> FlagName -> Either FlagName Bool-    env flags flag = (maybe (Left flag) Right . lookupFlagAssignment flag) flags---- | Transforms a 'CondTree' by putting the input under the "then" branch of a--- conditional that is True when Buildable is True. If 'addBuildableCondition'--- can determine that Buildable is always True, it returns the input unchanged.--- If Buildable is always False, it returns the empty 'CondTree'.-addBuildableCondition :: (Eq v, Monoid a, Monoid c) => (a -> BuildInfo)-                      -> CondTree v c a-                      -> CondTree v c a-addBuildableCondition getInfo t =-  case extractCondition (buildable . getInfo) t of-    Lit True  -> t-    Lit False -> CondNode mempty mempty []-    c         -> CondNode mempty mempty [condIfThen c t]---- | This is a special version of 'addBuildableCondition' for the 'PDTagged'--- type.------ It is not simply a specialisation. It is more complicated than it--- ought to be because of the way the 'PDTagged' monoid instance works. The--- @mempty = 'PDNull'@ forgets the component type, which has the effect of--- completely deleting components that are not buildable.------ See <https://github.com/haskell/cabal/pull/4094> for more details.----addBuildableConditionPDTagged :: (Eq v, Monoid c) =>-                                 CondTree v c PDTagged-                              -> CondTree v c PDTagged-addBuildableConditionPDTagged t =-    case extractCondition (buildable . getInfo) t of-      Lit True  -> t-      Lit False -> deleteConstraints t-      c         -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)]-  where-    deleteConstraints = mapTreeConstrs (const mempty)--    getInfo :: PDTagged -> BuildInfo-    getInfo (Lib l) = libBuildInfo l-    getInfo (SubComp _ c) = componentBuildInfo c-    getInfo PDNull = mempty----- Note: extracting buildable conditions.--- -------------------------------------------- If the conditions in a cond tree lead to Buildable being set to False, then--- none of the dependencies for this cond tree should actually be taken into--- account. On the other hand, some of the flags may only be decided in the--- solver, so we cannot necessarily make the decision whether a component is--- Buildable or not prior to solving.------ What we are doing here is to partially evaluate a condition tree in order to--- extract the condition under which Buildable is True. The predicate determines--- whether data under a 'CondTree' is buildable.---- | Extract conditions matched by the given predicate from all cond trees in a--- 'GenericPackageDescription'.-extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription-                     -> [Condition ConfVar]-extractConditions f gpkg =-  concat [-      extractCondition (f . libBuildInfo)             <$> maybeToList (condLibrary gpkg)-    , extractCondition (f . libBuildInfo)       . snd <$> condSubLibraries   gpkg-    , extractCondition (f . buildInfo)          . snd <$> condExecutables gpkg-    , extractCondition (f . testBuildInfo)      . snd <$> condTestSuites  gpkg-    , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks  gpkg-    ]----- | A map of package constraints that combines version ranges using 'unionVersionRanges'.-newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName) }--instance Semigroup DepMapUnion where-    DepMapUnion x <> DepMapUnion y = DepMapUnion $-        Map.unionWith unionVersionRanges' x y--unionVersionRanges'-    :: (VersionRange, NonEmptySet LibraryName)-    -> (VersionRange, NonEmptySet LibraryName)-    -> (VersionRange, NonEmptySet LibraryName)-unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs')--toDepMapUnion :: [Dependency] -> DepMapUnion-toDepMapUnion ds =-  DepMapUnion $ Map.fromListWith unionVersionRanges' [ (p,(vr,cs)) | Dependency p vr cs <- ds ]---fromDepMapUnion :: DepMapUnion -> [Dependency]-fromDepMapUnion m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDepMapUnion m) ]--freeVars :: CondTree ConfVar c a  -> [FlagName]-freeVars t = [ f | PackageFlag f <- freeVars' t ]-  where-    freeVars' (CondNode _ _ ifs) = concatMap compfv ifs-    compfv (CondBranch c ct mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct-    condfv c = case c of-      Var v      -> [v]-      Lit _      -> []-      CNot c'    -> condfv c'-      COr c1 c2  -> condfv c1 ++ condfv c2-      CAnd c1 c2 -> condfv c1 ++ condfv c2------------------------------------------------------------------------------------- | A set of targets with their package dependencies-newtype TargetSet a = TargetSet [(DependencyMap, a)]---- | Combine the target-specific dependencies in a TargetSet to give the--- dependencies for the package as a whole.-overallDependencies :: ComponentRequestedSpec -> TargetSet PDTagged -> DependencyMap-overallDependencies enabled (TargetSet targets) = mconcat depss-  where-    (depss, _) = unzip $ filter (removeDisabledSections . snd) targets-    removeDisabledSections :: PDTagged -> Bool-    -- UGH. The embedded componentName in the 'Component's here is-    -- BLANK.  I don't know whose fault this is but I'll use the tag-    -- instead. -- ezyang-    removeDisabledSections (Lib _)     = componentNameRequested-                                           enabled-                                           (CLibName LMainLibName)-    removeDisabledSections (SubComp t c)-        -- Do NOT use componentName-        = componentNameRequested enabled-        $ case c of-            CLib  _ -> CLibName (LSubLibName t)-            CFLib _ -> CFLibName   t-            CExe  _ -> CExeName    t-            CTest _ -> CTestName   t-            CBench _ -> CBenchName t-    removeDisabledSections PDNull      = True---- | Collect up the targets in a TargetSet of tagged targets, storing the--- dependencies as we go.-flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(UnqualComponentName, Component)])-flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets where-  untag (depMap, pdTagged) accum = case (pdTagged, accum) of-    (Lib _, (Just _, _)) -> userBug "Only one library expected"-    (Lib l, (Nothing, comps)) -> (Just $ redoBD l, comps)-    (SubComp n c, (mb_lib, comps))-      | any ((== n) . fst) comps ->-        userBug $ "There exist several components with the same name: '" ++ prettyShow n ++ "'"-      | otherwise -> (mb_lib, (n, redoBD c) : comps)-    (PDNull, x) -> x  -- actually this should not happen, but let's be liberal-    where-      redoBD :: L.HasBuildInfo a => a -> a-      redoBD = set L.targetBuildDepends $ fromDepMap depMap----------------------------------------------------------------------------------- Convert GenericPackageDescription to PackageDescription-----data PDTagged = Lib Library-              | SubComp UnqualComponentName Component-              | PDNull-              deriving Show--instance Monoid PDTagged where-    mempty = PDNull-    mappend = (<>)--instance Semigroup PDTagged where-    PDNull    <> x      = x-    x         <> PDNull = x-    Lib l     <> Lib l' = Lib (l <> l')-    SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x')-    _         <> _  = cabalBug "Cannot combine incompatible tags"---- | Create a package description with all configurations resolved.------ This function takes a `GenericPackageDescription` and several environment--- parameters and tries to generate `PackageDescription` by finding a flag--- assignment that result in satisfiable dependencies.------ It takes as inputs a not necessarily complete specifications of flags--- assignments, an optional package index as well as platform parameters.  If--- some flags are not assigned explicitly, this function will try to pick an--- assignment that causes this function to succeed.  The package index is--- optional since on some platforms we cannot determine which packages have--- been installed before.  When no package index is supplied, every dependency--- is assumed to be satisfiable, therefore all not explicitly assigned flags--- will get their default values.------ This function will fail if it cannot find a flag assignment that leads to--- satisfiable dependencies.  (It will not try alternative assignments for--- explicitly specified flags.)  In case of failure it will return the missing--- dependencies that it encountered when trying different flag assignments.--- On success, it will return the package description and the full flag--- assignment chosen.------ Note that this drops any stanzas which have @buildable: False@.  While--- this is arguably the right thing to do, it means we give bad error--- messages in some situations, see #3858.----finalizePD ::-     FlagAssignment  -- ^ Explicitly specified flag assignments-  -> ComponentRequestedSpec-  -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of-                          -- available packages?  If this is unknown then use-                          -- True.-  -> Platform      -- ^ The 'Arch' and 'OS'-  -> CompilerInfo  -- ^ Compiler information-  -> [PackageVersionConstraint]  -- ^ Additional constraints-  -> GenericPackageDescription-  -> Either [Dependency]-            (PackageDescription, FlagAssignment)-             -- ^ Either missing dependencies or the resolved package-             -- description along with the flag assignments chosen.-finalizePD userflags enabled satisfyDep-        (Platform arch os) impl constraints-        (GenericPackageDescription pkg _ver flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) = do-  (targetSet, flagVals) <--    resolveWithFlags flagChoices enabled os arch impl constraints condTrees check-  let-    (mb_lib, comps) = flattenTaggedTargets targetSet-    mb_lib' = fmap libFillInDefaults mb_lib-    comps' = flip map comps $ \(n,c) -> foldComponent-      (\l -> CLib   (libFillInDefaults l)   { libName = LSubLibName n-                                            , libExposed = False })-      (\l -> CFLib  (flibFillInDefaults l)  { foreignLibName = n })-      (\e -> CExe   (exeFillInDefaults e)   { exeName = n })-      (\t -> CTest  (testFillInDefaults t)  { testName = n })-      (\b -> CBench (benchFillInDefaults b) { benchmarkName = n })-      c-    (sub_libs', flibs', exes', tests', bms') = partitionComponents comps'-  return ( pkg { library = mb_lib'-               , subLibraries = sub_libs'-               , foreignLibs = flibs'-               , executables = exes'-               , testSuites = tests'-               , benchmarks = bms'-               }-         , flagVals )-  where-    -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data-    condTrees =    maybeToList (fmap (mapTreeData Lib) mb_lib0)-                ++ map (\(name,tree) -> mapTreeData (SubComp name . CLib) tree) sub_libs0-                ++ map (\(name,tree) -> mapTreeData (SubComp name . CFLib) tree) flibs0-                ++ map (\(name,tree) -> mapTreeData (SubComp name . CExe) tree) exes0-                ++ map (\(name,tree) -> mapTreeData (SubComp name . CTest) tree) tests0-                ++ map (\(name,tree) -> mapTreeData (SubComp name . CBench) tree) bms0--    flagChoices    = map (\(MkPackageFlag n _ d manual) -> (n, d2c manual n d)) flags-    d2c manual n b = case lookupFlagAssignment n userflags of-                     Just val -> [val]-                     Nothing-                      | manual -> [b]-                      | otherwise -> [b, not b]-    --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices-    check ds     = let missingDeps = filter (not . satisfyDep) ds-                   in if null missingDeps-                      then DepOk-                      else MissingDeps missingDeps--{--let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] [])-let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] [])--let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])]-let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index-let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds-resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks   ===>  Right ...-resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks  ===>  Left ...--}---- | Flatten a generic package description by ignoring all conditions and just--- join the field descriptors into on package description.  Note, however,--- that this may lead to inconsistent field values, since all values are--- joined into one field, which may not be possible in the original package--- description, due to the use of exclusive choices (if ... else ...).------ TODO: One particularly tricky case is defaulting.  In the original package--- description, e.g., the source directory might either be the default or a--- certain, explicitly set path.  Since defaults are filled in only after the--- package has been resolved and when no explicit value has been set, the--- default path will be missing from the package description returned by this--- function.-flattenPackageDescription :: GenericPackageDescription -> PackageDescription-flattenPackageDescription-  (GenericPackageDescription pkg _ _ mlib0 sub_libs0 flibs0 exes0 tests0 bms0) =-    pkg { library      = mlib-        , subLibraries = reverse sub_libs-        , foreignLibs  = reverse flibs-        , executables  = reverse exes-        , testSuites   = reverse tests-        , benchmarks   = reverse bms-        }-  where-    mlib = f <$> mlib0-      where f lib = (libFillInDefaults . fst . ignoreConditions $ lib) { libName = LMainLibName }-    sub_libs = flattenLib  <$> sub_libs0-    flibs    = flattenFLib <$> flibs0-    exes     = flattenExe  <$> exes0-    tests    = flattenTst  <$> tests0-    bms      = flattenBm   <$> bms0-    flattenLib (n, t) = libFillInDefaults $ (fst $ ignoreConditions t)-      { libName = LSubLibName n, libExposed = False }-    flattenFLib (n, t) = flibFillInDefaults $ (fst $ ignoreConditions t)-      { foreignLibName = n }-    flattenExe (n, t) = exeFillInDefaults $ (fst $ ignoreConditions t)-      { exeName = n }-    flattenTst (n, t) = testFillInDefaults $ (fst $ ignoreConditions t)-      { testName = n }-    flattenBm (n, t) = benchFillInDefaults $ (fst $ ignoreConditions t)-      { benchmarkName = n }---- This is in fact rather a hack.  The original version just overrode the--- default values, however, when adding conditions we had to switch to a--- modifier-based approach.  There, nothing is ever overwritten, but only--- joined together.------ This is the cleanest way i could think of, that doesn't require--- changing all field parsing functions to return modifiers instead.-libFillInDefaults :: Library -> Library-libFillInDefaults lib@(Library { libBuildInfo = bi }) =-    lib { libBuildInfo = biFillInDefaults bi }--flibFillInDefaults :: ForeignLib -> ForeignLib-flibFillInDefaults flib@(ForeignLib { foreignLibBuildInfo = bi }) =-    flib { foreignLibBuildInfo = biFillInDefaults bi }--exeFillInDefaults :: Executable -> Executable-exeFillInDefaults exe@(Executable { buildInfo = bi }) =-    exe { buildInfo = biFillInDefaults bi }--testFillInDefaults :: TestSuite -> TestSuite-testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) =-    tst { testBuildInfo = biFillInDefaults bi }--benchFillInDefaults :: Benchmark -> Benchmark-benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) =-    bm { benchmarkBuildInfo = biFillInDefaults bi }--biFillInDefaults :: BuildInfo -> BuildInfo-biFillInDefaults bi =-    if null (hsSourceDirs bi)-    then bi { hsSourceDirs = [sameDirectory] }-    else bi---- Walk a 'GenericPackageDescription' and apply @onBuildInfo@/@onSetupBuildInfo@--- to all nested 'BuildInfo'/'SetupBuildInfo' values.-transformAllBuildInfos :: (BuildInfo -> BuildInfo)-                       -> (SetupBuildInfo -> SetupBuildInfo)-                       -> GenericPackageDescription-                       -> GenericPackageDescription-transformAllBuildInfos onBuildInfo onSetupBuildInfo =-  over L.traverseBuildInfos onBuildInfo-  . over (L.packageDescription . L.setupBuildInfo . traverse) onSetupBuildInfo---- | Walk a 'GenericPackageDescription' and apply @f@ to all nested--- @build-depends@ fields.-transformAllBuildDepends :: (Dependency -> Dependency)-                         -> GenericPackageDescription-                         -> GenericPackageDescription-transformAllBuildDepends f =-  over (L.traverseBuildInfos . L.targetBuildDepends . traverse) f-  . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f-  -- cannot be point-free as normal because of higher rank-  . over (\f' -> L.allCondTrees $ traverseCondTreeC f') (map f)---- | Walk a 'GenericPackageDescription' and apply @f@ to all nested--- @build-depends@ fields.-transformAllBuildDependsN :: ([Dependency] -> [Dependency])-                          -> GenericPackageDescription-                          -> GenericPackageDescription-transformAllBuildDependsN f =-  over (L.traverseBuildInfos . L.targetBuildDepends) f-  . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends) f-  -- cannot be point-free as normal because of higher rank-  . over (\f' -> L.allCondTrees $ traverseCondTreeC f') f
− src/Distribution/PackageDescription/FieldGrammar.hs 
@@ -1,802 +0,0 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}--- | 'GenericPackageDescription' Field descriptions-module Distribution.PackageDescription.FieldGrammar (-    -- * Package description-    packageDescriptionFieldGrammar,-    -- * Library-    libraryFieldGrammar,-    -- * Foreign library-    foreignLibFieldGrammar,-    -- * Executable-    executableFieldGrammar,-    -- * Test suite-    TestSuiteStanza (..),-    testSuiteFieldGrammar,-    validateTestSuite,-    unvalidateTestSuite,-    -- ** Lenses-    testStanzaTestType,-    testStanzaMainIs,-    testStanzaTestModule,-    testStanzaBuildInfo,-    -- * Benchmark-    BenchmarkStanza (..),-    benchmarkFieldGrammar,-    validateBenchmark,-    unvalidateBenchmark,-    -- * Field grammars-    formatDependencyList,-    formatExposedModules,-    formatExtraSourceFiles,-    formatHsSourceDirs,-    formatMixinList,-    formatOtherExtensions,-    formatOtherModules,-    -- ** Lenses-    benchmarkStanzaBenchmarkType,-    benchmarkStanzaMainIs,-    benchmarkStanzaBenchmarkModule,-    benchmarkStanzaBuildInfo,-    -- * Flag-    flagFieldGrammar,-    -- * Source repository-    sourceRepoFieldGrammar,-    -- * Setup build info-    setupBInfoFieldGrammar,-    -- * Component build info-    buildInfoFieldGrammar,-    ) where---import Distribution.Compat.Lens-import Distribution.Compat.Prelude-import Language.Haskell.Extension-import Prelude ()--import Distribution.CabalSpecVersion-import Distribution.Compat.Newtype     (Newtype, pack', unpack')-import Distribution.Compiler           (CompilerFlavor (..), PerCompilerFlavor (..))-import Distribution.FieldGrammar-import Distribution.Fields-import Distribution.ModuleName         (ModuleName)-import Distribution.Package-import Distribution.PackageDescription-import Distribution.Parsec-import Distribution.Pretty             (Pretty (..), prettyShow, showToken)-import Distribution.Utils.Path-import Distribution.Version            (Version, VersionRange)--import qualified Data.ByteString.Char8           as BS8-import qualified Distribution.Compat.CharParsing as P-import qualified Distribution.SPDX               as SPDX-import qualified Distribution.Types.Lens         as L------------------------------------------------------------------------------------ PackageDescription----------------------------------------------------------------------------------packageDescriptionFieldGrammar-    :: ( FieldGrammar c g, Applicative (g PackageDescription), Applicative (g PackageIdentifier)-       , c (Identity BuildType)-       , c (Identity PackageName)-       , c (Identity Version)-       , c (List FSep FilePathNT String)-       , c (List FSep CompatFilePath String)-       , c (List FSep (Identity (SymbolicPath PackageDir LicenseFile)) (SymbolicPath PackageDir LicenseFile))-       , c (List FSep TestedWith (CompilerFlavor, VersionRange))-       , c (List VCat FilePathNT String)-       , c FilePathNT-       , c CompatLicenseFile-       , c CompatFilePath-       , c SpecLicense-       , c SpecVersion-       )-    => g PackageDescription PackageDescription-packageDescriptionFieldGrammar = PackageDescription-    <$> optionalFieldDefAla "cabal-version" SpecVersion                L.specVersion CabalSpecV1_0-    <*> blurFieldGrammar L.package packageIdentifierGrammar-    <*> optionalFieldDefAla "license"       SpecLicense                L.licenseRaw (Left SPDX.NONE)-    <*> licenseFilesGrammar-    <*> freeTextFieldDefST  "copyright"                                L.copyright-    <*> freeTextFieldDefST  "maintainer"                               L.maintainer-    <*> freeTextFieldDefST  "author"                                   L.author-    <*> freeTextFieldDefST  "stability"                                L.stability-    <*> monoidalFieldAla    "tested-with"   (alaList' FSep TestedWith) L.testedWith-    <*> freeTextFieldDefST  "homepage"                                 L.homepage-    <*> freeTextFieldDefST  "package-url"                              L.pkgUrl-    <*> freeTextFieldDefST   "bug-reports"                              L.bugReports-    <*> pure [] -- source-repos are stanza-    <*> freeTextFieldDefST  "synopsis"                                 L.synopsis-    <*> freeTextFieldDefST  "description"                              L.description-    <*> freeTextFieldDefST  "category"                                 L.category-    <*> prefixedFields      "x-"                                       L.customFieldsPD-    <*> optionalField       "build-type"                               L.buildTypeRaw-    <*> pure Nothing -- custom-setup-    -- components-    <*> pure Nothing  -- lib-    <*> pure []       -- sub libs-    <*> pure []       -- executables-    <*> pure []       -- foreign libs-    <*> pure []       -- test suites-    <*> pure []       -- benchmarks-    --  * Files-    <*> monoidalFieldAla    "data-files"         (alaList' VCat FilePathNT) L.dataFiles-    <*> optionalFieldDefAla "data-dir"           CompatFilePath             L.dataDir "."-        ^^^ fmap (\x -> if null x then "." else x) -- map empty directories to "."-    <*> monoidalFieldAla    "extra-source-files" formatExtraSourceFiles     L.extraSrcFiles-    <*> monoidalFieldAla    "extra-tmp-files"    (alaList' VCat FilePathNT) L.extraTmpFiles-    <*> monoidalFieldAla    "extra-doc-files"    (alaList' VCat FilePathNT) L.extraDocFiles-  where-    packageIdentifierGrammar = PackageIdentifier-        <$> uniqueField "name"    L.pkgName-        <*> uniqueField "version" L.pkgVersion--    licenseFilesGrammar = (++)-        -- TODO: neither field is deprecated-        -- should we pretty print license-file if there's single license file-        -- and license-files when more-        <$> monoidalFieldAla    "license-file"   CompatLicenseFile L.licenseFiles-        <*> monoidalFieldAla    "license-files"  (alaList FSep)    L.licenseFiles-            ^^^ hiddenField------------------------------------------------------------------------------------ Library----------------------------------------------------------------------------------libraryFieldGrammar-    :: ( FieldGrammar c g, Applicative (g Library), Applicative (g BuildInfo)-       , c (Identity LibraryVisibility)-       , c (List CommaFSep (Identity ExeDependency) ExeDependency)-       , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)-       , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)-       , c (List CommaVCat (Identity Dependency) Dependency)-       , c (List CommaVCat (Identity Mixin) Mixin)-       , c (List CommaVCat (Identity ModuleReexport) ModuleReexport)-       , c (List FSep (MQuoted Extension) Extension)-       , c (List FSep (MQuoted Language) Language)-       , c (List FSep FilePathNT String)-       , c (List FSep Token String)-       , c (List NoCommaFSep Token' String)-       , c (List VCat (MQuoted ModuleName) ModuleName)-       , c (List VCat FilePathNT String)-       , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))-       , c (List VCat Token String)-       , c (MQuoted Language)-       )-    => LibraryName-    -> g Library Library-libraryFieldGrammar n = Library n-    <$> monoidalFieldAla  "exposed-modules"    formatExposedModules    L.exposedModules-    <*> monoidalFieldAla  "reexported-modules" (alaList  CommaVCat)    L.reexportedModules-    <*> monoidalFieldAla  "signatures"         (alaList' VCat MQuoted) L.signatures-        ^^^ availableSince CabalSpecV2_0 []-    <*> booleanFieldDef   "exposed"                                    L.libExposed True-    <*> visibilityField-    <*> blurFieldGrammar L.libBuildInfo buildInfoFieldGrammar-  where-    visibilityField = case n of-        -- nameless/"main" libraries are public-        LMainLibName -> pure LibraryVisibilityPublic-        -- named libraries have the field-        LSubLibName _ ->-            optionalFieldDef "visibility" L.libVisibility LibraryVisibilityPrivate-            ^^^ availableSince CabalSpecV3_0 LibraryVisibilityPrivate--{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> ParsecFieldGrammar' Library #-}-{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> PrettyFieldGrammar' Library #-}------------------------------------------------------------------------------------ Foreign library----------------------------------------------------------------------------------foreignLibFieldGrammar-    :: ( FieldGrammar c g, Applicative (g ForeignLib), Applicative (g BuildInfo)-       , c (Identity ForeignLibType)-       , c (Identity LibVersionInfo)-       , c (Identity Version)-       , c (List CommaFSep (Identity ExeDependency) ExeDependency)-       , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)-       , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)-       , c (List CommaVCat (Identity Dependency) Dependency)-       , c (List CommaVCat (Identity Mixin) Mixin)-       , c (List FSep (Identity ForeignLibOption) ForeignLibOption)-       , c (List FSep (MQuoted Extension) Extension)-       , c (List FSep (MQuoted Language) Language)-       , c (List FSep FilePathNT String)-       , c (List FSep Token String)-       , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))-       , c (List NoCommaFSep Token' String)-       , c (List VCat (MQuoted ModuleName) ModuleName)-       , c (List VCat FilePathNT String), c (List VCat Token String)-       , c (MQuoted Language)-       )-    => UnqualComponentName -> g ForeignLib ForeignLib-foreignLibFieldGrammar n = ForeignLib n-    <$> optionalFieldDef "type"                                         L.foreignLibType ForeignLibTypeUnknown-    <*> monoidalFieldAla "options"           (alaList FSep)             L.foreignLibOptions-    <*> blurFieldGrammar L.foreignLibBuildInfo buildInfoFieldGrammar-    <*> optionalField    "lib-version-info"                             L.foreignLibVersionInfo-    <*> optionalField    "lib-version-linux"                            L.foreignLibVersionLinux-    <*> monoidalFieldAla "mod-def-file"      (alaList' FSep FilePathNT) L.foreignLibModDefFile-{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' ForeignLib #-}-{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' ForeignLib #-}------------------------------------------------------------------------------------ Executable----------------------------------------------------------------------------------executableFieldGrammar-    :: ( FieldGrammar c g, Applicative (g Executable), Applicative (g BuildInfo)-       , c (Identity ExecutableScope)-       , c (List CommaFSep (Identity ExeDependency) ExeDependency)-       , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)-       , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)-       , c (List CommaVCat (Identity Dependency) Dependency)-       , c (List CommaVCat (Identity Mixin) Mixin)-       , c (List FSep (MQuoted Extension) Extension)-       , c (List FSep (MQuoted Language) Language)-       , c (List FSep FilePathNT String)-       , c (List FSep Token String)-       , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))-       , c (List NoCommaFSep Token' String)-       , c (List VCat (MQuoted ModuleName) ModuleName)-       , c (List VCat FilePathNT String)-       , c (List VCat Token String)-       , c (MQuoted Language)-       )-    => UnqualComponentName -> g Executable Executable-executableFieldGrammar n = Executable n-    -- main-is is optional as conditional blocks don't have it-    <$> optionalFieldDefAla "main-is" FilePathNT L.modulePath ""-    <*> optionalFieldDef    "scope"              L.exeScope ExecutablePublic-        ^^^ availableSince CabalSpecV2_0 ExecutablePublic-    <*> blurFieldGrammar L.buildInfo buildInfoFieldGrammar-{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' Executable #-}-{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' Executable #-}------------------------------------------------------------------------------------ TestSuite------------------------------------------------------------------------------------ | An intermediate type just used for parsing the test-suite stanza.--- After validation it is converted into the proper 'TestSuite' type.-data TestSuiteStanza = TestSuiteStanza-    { _testStanzaTestType   :: Maybe TestType-    , _testStanzaMainIs     :: Maybe FilePath-    , _testStanzaTestModule :: Maybe ModuleName-    , _testStanzaBuildInfo  :: BuildInfo-    }--instance L.HasBuildInfo TestSuiteStanza where-    buildInfo = testStanzaBuildInfo--testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType)-testStanzaTestType f s = fmap (\x -> s { _testStanzaTestType = x }) (f (_testStanzaTestType s))-{-# INLINE testStanzaTestType #-}--testStanzaMainIs :: Lens' TestSuiteStanza (Maybe FilePath)-testStanzaMainIs f s = fmap (\x -> s { _testStanzaMainIs = x }) (f (_testStanzaMainIs s))-{-# INLINE testStanzaMainIs #-}--testStanzaTestModule :: Lens' TestSuiteStanza (Maybe ModuleName)-testStanzaTestModule f s = fmap (\x -> s { _testStanzaTestModule = x }) (f (_testStanzaTestModule s))-{-# INLINE testStanzaTestModule #-}--testStanzaBuildInfo :: Lens' TestSuiteStanza BuildInfo-testStanzaBuildInfo f s = fmap (\x -> s { _testStanzaBuildInfo = x }) (f (_testStanzaBuildInfo s))-{-# INLINE testStanzaBuildInfo #-}--testSuiteFieldGrammar-    :: ( FieldGrammar c g, Applicative (g TestSuiteStanza), Applicative (g BuildInfo)-       , c (Identity ModuleName)-       , c (Identity TestType)-       , c (List CommaFSep (Identity ExeDependency) ExeDependency)-       , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)-       , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)-       , c (List CommaVCat (Identity Dependency) Dependency)-       , c (List CommaVCat (Identity Mixin) Mixin)-       , c (List FSep (MQuoted Extension) Extension)-       , c (List FSep (MQuoted Language) Language)-       , c (List FSep FilePathNT String)-       , c (List FSep Token String)-       , c (List NoCommaFSep Token' String)-       , c (List VCat (MQuoted ModuleName) ModuleName)-       , c (List VCat FilePathNT String)-       , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))-       , c (List VCat Token String)-       , c (MQuoted Language)-       )-    => g TestSuiteStanza TestSuiteStanza-testSuiteFieldGrammar = TestSuiteStanza-    <$> optionalField    "type"                   testStanzaTestType-    <*> optionalFieldAla "main-is"     FilePathNT testStanzaMainIs-    <*> optionalField    "test-module"            testStanzaTestModule-    <*> blurFieldGrammar testStanzaBuildInfo buildInfoFieldGrammar--validateTestSuite :: Position -> TestSuiteStanza -> ParseResult TestSuite-validateTestSuite pos stanza = case _testStanzaTestType stanza of-    Nothing -> return $-        emptyTestSuite { testBuildInfo = _testStanzaBuildInfo stanza }--    Just tt@(TestTypeUnknown _ _) ->-        pure emptyTestSuite-            { testInterface = TestSuiteUnsupported tt-            , testBuildInfo = _testStanzaBuildInfo stanza-            }--    Just tt | tt `notElem` knownTestTypes ->-        pure emptyTestSuite-            { testInterface = TestSuiteUnsupported tt-            , testBuildInfo = _testStanzaBuildInfo stanza-            }--    Just tt@(TestTypeExe ver) -> case _testStanzaMainIs stanza of-        Nothing   -> do-            parseFailure pos (missingField "main-is" tt)-            pure emptyTestSuite-        Just file -> do-            when (isJust (_testStanzaTestModule stanza)) $-                parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt)-            pure emptyTestSuite-                { testInterface = TestSuiteExeV10 ver file-                , testBuildInfo = _testStanzaBuildInfo stanza-                }--    Just tt@(TestTypeLib ver) -> case _testStanzaTestModule stanza of-         Nothing      -> do-             parseFailure pos (missingField "test-module" tt)-             pure emptyTestSuite-         Just module_ -> do-            when (isJust (_testStanzaMainIs stanza)) $-                parseWarning pos PWTExtraMainIs (extraField "main-is" tt)-            pure emptyTestSuite-                { testInterface = TestSuiteLibV09 ver module_-                , testBuildInfo = _testStanzaBuildInfo stanza-                }--  where-    missingField name tt = "The '" ++ name ++ "' field is required for the "-                        ++ prettyShow tt ++ " test suite type."--    extraField   name tt = "The '" ++ name ++ "' field is not used for the '"-                        ++ prettyShow tt ++ "' test suite type."--unvalidateTestSuite :: TestSuite -> TestSuiteStanza-unvalidateTestSuite t = TestSuiteStanza-    { _testStanzaTestType   = ty-    , _testStanzaMainIs     = ma-    , _testStanzaTestModule = mo-    , _testStanzaBuildInfo  = testBuildInfo t-    }-  where-    (ty, ma, mo) = case testInterface t of-        TestSuiteExeV10 ver file -> (Just $ TestTypeExe ver, Just file, Nothing)-        TestSuiteLibV09 ver modu -> (Just $ TestTypeLib ver, Nothing, Just modu)-        _                        -> (Nothing, Nothing, Nothing)------------------------------------------------------------------------------------ Benchmark------------------------------------------------------------------------------------ | An intermediate type just used for parsing the benchmark stanza.--- After validation it is converted into the proper 'Benchmark' type.-data BenchmarkStanza = BenchmarkStanza-    { _benchmarkStanzaBenchmarkType   :: Maybe BenchmarkType-    , _benchmarkStanzaMainIs          :: Maybe FilePath-    , _benchmarkStanzaBenchmarkModule :: Maybe ModuleName-    , _benchmarkStanzaBuildInfo       :: BuildInfo-    }--instance L.HasBuildInfo BenchmarkStanza where-    buildInfo = benchmarkStanzaBuildInfo--benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType)-benchmarkStanzaBenchmarkType f s = fmap (\x -> s { _benchmarkStanzaBenchmarkType = x }) (f (_benchmarkStanzaBenchmarkType s))-{-# INLINE benchmarkStanzaBenchmarkType #-}--benchmarkStanzaMainIs :: Lens' BenchmarkStanza (Maybe FilePath)-benchmarkStanzaMainIs f s = fmap (\x -> s { _benchmarkStanzaMainIs = x }) (f (_benchmarkStanzaMainIs s))-{-# INLINE benchmarkStanzaMainIs #-}--benchmarkStanzaBenchmarkModule :: Lens' BenchmarkStanza (Maybe ModuleName)-benchmarkStanzaBenchmarkModule f s = fmap (\x -> s { _benchmarkStanzaBenchmarkModule = x }) (f (_benchmarkStanzaBenchmarkModule s))-{-# INLINE benchmarkStanzaBenchmarkModule #-}--benchmarkStanzaBuildInfo :: Lens' BenchmarkStanza BuildInfo-benchmarkStanzaBuildInfo f s = fmap (\x -> s { _benchmarkStanzaBuildInfo = x }) (f (_benchmarkStanzaBuildInfo s))-{-# INLINE benchmarkStanzaBuildInfo #-}--benchmarkFieldGrammar-    :: ( FieldGrammar c g, Applicative (g BenchmarkStanza), Applicative (g BuildInfo)-       , c (Identity BenchmarkType)-       , c (Identity ModuleName)-       , c (List CommaFSep (Identity ExeDependency) ExeDependency)-       , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)-       , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)-       , c (List CommaVCat (Identity Dependency) Dependency)-       , c (List CommaVCat (Identity Mixin) Mixin)-       , c (List FSep (MQuoted Extension) Extension)-       , c (List FSep (MQuoted Language) Language)-       , c (List FSep FilePathNT String)-       , c (List FSep Token String)-       , c (List NoCommaFSep Token' String)-       , c (List VCat (MQuoted ModuleName) ModuleName)-       , c (List VCat FilePathNT String)-       , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))-       , c (List VCat Token String)-       , c (MQuoted Language)-       )-    => g BenchmarkStanza BenchmarkStanza-benchmarkFieldGrammar = BenchmarkStanza-    <$> optionalField    "type"                        benchmarkStanzaBenchmarkType-    <*> optionalFieldAla "main-is"          FilePathNT benchmarkStanzaMainIs-    <*> optionalField    "benchmark-module"            benchmarkStanzaBenchmarkModule-    <*> blurFieldGrammar benchmarkStanzaBuildInfo buildInfoFieldGrammar--validateBenchmark :: Position -> BenchmarkStanza -> ParseResult Benchmark-validateBenchmark pos stanza = case _benchmarkStanzaBenchmarkType stanza of-    Nothing -> pure emptyBenchmark-        { benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza }--    Just tt@(BenchmarkTypeUnknown _ _) -> pure emptyBenchmark-        { benchmarkInterface = BenchmarkUnsupported tt-        , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza-        }--    Just tt | tt `notElem` knownBenchmarkTypes -> pure emptyBenchmark-        { benchmarkInterface = BenchmarkUnsupported tt-        , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza-        }--    Just tt@(BenchmarkTypeExe ver) -> case _benchmarkStanzaMainIs stanza of-        Nothing   -> do-            parseFailure pos (missingField "main-is" tt)-            pure emptyBenchmark-        Just file -> do-            when (isJust (_benchmarkStanzaBenchmarkModule stanza)) $-                parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt)-            pure emptyBenchmark-                { benchmarkInterface = BenchmarkExeV10 ver file-                , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza-                }--  where-    missingField name tt = "The '" ++ name ++ "' field is required for the "-                        ++ prettyShow tt ++ " benchmark type."--    extraField   name tt = "The '" ++ name ++ "' field is not used for the '"-                        ++ prettyShow tt ++ "' benchmark type."--unvalidateBenchmark :: Benchmark -> BenchmarkStanza-unvalidateBenchmark b = BenchmarkStanza-    { _benchmarkStanzaBenchmarkType   = ty-    , _benchmarkStanzaMainIs          = ma-    , _benchmarkStanzaBenchmarkModule = mo-    , _benchmarkStanzaBuildInfo       = benchmarkBuildInfo b-    }-  where-    (ty, ma, mo) = case benchmarkInterface b of-        BenchmarkExeV10 ver ""  -> (Just $ BenchmarkTypeExe ver, Nothing,  Nothing)-        BenchmarkExeV10 ver ma' -> (Just $ BenchmarkTypeExe ver, Just ma', Nothing)-        _                       -> (Nothing, Nothing,  Nothing)------------------------------------------------------------------------------------ Build info----------------------------------------------------------------------------------buildInfoFieldGrammar-    :: ( FieldGrammar c g, Applicative (g BuildInfo)-       , c (List CommaFSep (Identity ExeDependency) ExeDependency)-       , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)-       , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)-       , c (List CommaVCat (Identity Dependency) Dependency)-       , c (List CommaVCat (Identity Mixin) Mixin)-       , c (List FSep (MQuoted Extension) Extension)-       , c (List FSep (MQuoted Language) Language)-       , c (List FSep FilePathNT String)-       , c (List FSep Token String)-       , c (List NoCommaFSep Token' String)-       , c (List VCat (MQuoted ModuleName) ModuleName)-       , c (List VCat FilePathNT String)-       , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))-       , c (List VCat Token String)-       , c (MQuoted Language)-       )-    => g BuildInfo BuildInfo-buildInfoFieldGrammar = BuildInfo-    <$> booleanFieldDef  "buildable"                                          L.buildable True-    <*> monoidalFieldAla "build-tools"          (alaList  CommaFSep)          L.buildTools-        ^^^ deprecatedSince CabalSpecV2_0-            "Please use 'build-tool-depends' field"-        ^^^ removedIn CabalSpecV3_0-            "Please use 'build-tool-depends' field."-    <*> monoidalFieldAla "build-tool-depends"   (alaList  CommaFSep)          L.buildToolDepends-        -- {- ^^^ availableSince [2,0] [] -}-        -- here, we explicitly want to recognise build-tool-depends for all Cabal files-        -- as otherwise cabal new-build cannot really work.-        ---        -- I.e. we don't want trigger unknown field warning-    <*> monoidalFieldAla "cpp-options"          (alaList' NoCommaFSep Token') L.cppOptions-    <*> monoidalFieldAla "asm-options"          (alaList' NoCommaFSep Token') L.asmOptions-        ^^^ availableSince CabalSpecV3_0 []-    <*> monoidalFieldAla "cmm-options"          (alaList' NoCommaFSep Token') L.cmmOptions-        ^^^ availableSince CabalSpecV3_0 []-    <*> monoidalFieldAla "cc-options"           (alaList' NoCommaFSep Token') L.ccOptions-    <*> monoidalFieldAla "cxx-options"          (alaList' NoCommaFSep Token') L.cxxOptions-        ^^^ availableSince CabalSpecV2_2 []-    <*> monoidalFieldAla "ld-options"           (alaList' NoCommaFSep Token') L.ldOptions-    <*> monoidalFieldAla "hsc2hs-options"       (alaList' NoCommaFSep Token') L.hsc2hsOptions-        ^^^ availableSince CabalSpecV3_6 []-    <*> monoidalFieldAla "pkgconfig-depends"    (alaList  CommaFSep)          L.pkgconfigDepends-    <*> monoidalFieldAla "frameworks"           (alaList' FSep Token)         L.frameworks-    <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep FilePathNT)    L.extraFrameworkDirs-    <*> monoidalFieldAla "asm-sources"          (alaList' VCat FilePathNT)    L.asmSources-        ^^^ availableSince CabalSpecV3_0 []-    <*> monoidalFieldAla "cmm-sources"          (alaList' VCat FilePathNT)    L.cmmSources-        ^^^ availableSince CabalSpecV3_0 []-    <*> monoidalFieldAla "c-sources"            (alaList' VCat FilePathNT)    L.cSources-    <*> monoidalFieldAla "cxx-sources"          (alaList' VCat FilePathNT)    L.cxxSources-        ^^^ availableSince CabalSpecV2_2 []-    <*> monoidalFieldAla "js-sources"           (alaList' VCat FilePathNT)    L.jsSources-    <*> hsSourceDirsGrammar-    <*> monoidalFieldAla "other-modules"        formatOtherModules            L.otherModules-    <*> monoidalFieldAla "virtual-modules"      (alaList' VCat MQuoted)       L.virtualModules-        ^^^ availableSince CabalSpecV2_2 []-    <*> monoidalFieldAla "autogen-modules"      (alaList' VCat MQuoted)       L.autogenModules-        ^^^ availableSince CabalSpecV2_0 []-    <*> optionalFieldAla "default-language"     MQuoted                       L.defaultLanguage-        ^^^ availableSince CabalSpecV1_10 Nothing-    <*> monoidalFieldAla "other-languages"      (alaList' FSep MQuoted)       L.otherLanguages-        ^^^ availableSince CabalSpecV1_10 []-    <*> monoidalFieldAla "default-extensions"   (alaList' FSep MQuoted)       L.defaultExtensions-        ^^^ availableSince CabalSpecV1_10 []-    <*> monoidalFieldAla "other-extensions"     formatOtherExtensions         L.otherExtensions-        ^^^ availableSinceWarn CabalSpecV1_10-    <*> monoidalFieldAla "extensions"           (alaList' FSep MQuoted)       L.oldExtensions-        ^^^ deprecatedSince CabalSpecV1_12-            "Please use 'default-extensions' or 'other-extensions' fields."-        ^^^ removedIn CabalSpecV3_0-            "Please use 'default-extensions' or 'other-extensions' fields."-    <*> monoidalFieldAla "extra-libraries"      (alaList' VCat Token)         L.extraLibs-    <*> monoidalFieldAla "extra-ghci-libraries" (alaList' VCat Token)         L.extraGHCiLibs-    <*> monoidalFieldAla "extra-bundled-libraries" (alaList' VCat Token)      L.extraBundledLibs-    <*> monoidalFieldAla "extra-library-flavours" (alaList' VCat Token)       L.extraLibFlavours-    <*> monoidalFieldAla "extra-dynamic-library-flavours" (alaList' VCat Token) L.extraDynLibFlavours-        ^^^ availableSince CabalSpecV3_0 []-    <*> monoidalFieldAla "extra-lib-dirs"       (alaList' FSep FilePathNT)    L.extraLibDirs-    <*> monoidalFieldAla "include-dirs"         (alaList' FSep FilePathNT)    L.includeDirs-    <*> monoidalFieldAla "includes"             (alaList' FSep FilePathNT)    L.includes-    <*> monoidalFieldAla "autogen-includes"     (alaList' FSep FilePathNT)    L.autogenIncludes-        ^^^ availableSince CabalSpecV3_0 []-    <*> monoidalFieldAla "install-includes"     (alaList' FSep FilePathNT)    L.installIncludes-    <*> optionsFieldGrammar-    <*> profOptionsFieldGrammar-    <*> sharedOptionsFieldGrammar-    <*> pure mempty -- static-options ???-    <*> prefixedFields   "x-"                                                 L.customFieldsBI-    <*> monoidalFieldAla "build-depends"        formatDependencyList          L.targetBuildDepends-    <*> monoidalFieldAla "mixins"               formatMixinList               L.mixins-        ^^^ availableSince CabalSpecV2_0 []-{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfo #-}-{-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfo #-}--hsSourceDirsGrammar-    :: ( FieldGrammar c g, Applicative (g BuildInfo)-       , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))-       )-    => g BuildInfo [SymbolicPath PackageDir SourceDir]-hsSourceDirsGrammar = (++)-    <$> monoidalFieldAla "hs-source-dirs" formatHsSourceDirs L.hsSourceDirs-    <*> monoidalFieldAla "hs-source-dir"  (alaList FSep) wrongLens-        --- https://github.com/haskell/cabal/commit/49e3cdae3bdf21b017ccd42e66670ca402e22b44-        ^^^ deprecatedSince CabalSpecV1_2 "Please use 'hs-source-dirs'"-        ^^^ removedIn CabalSpecV3_0 "Please use 'hs-source-dirs' field."-  where-    -- TODO: make pretty printer aware of CabalSpecVersion-    wrongLens :: Functor f => LensLike' f BuildInfo [SymbolicPath PackageDir SourceDir]-    wrongLens f bi = (\fps -> set L.hsSourceDirs fps bi) <$> f []--optionsFieldGrammar-    :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String))-    => g BuildInfo (PerCompilerFlavor [String])-optionsFieldGrammar = PerCompilerFlavor-    <$> monoidalFieldAla "ghc-options"   (alaList' NoCommaFSep Token') (extract GHC)-    <*> monoidalFieldAla "ghcjs-options" (alaList' NoCommaFSep Token') (extract GHCJS)-    -- NOTE: Hugs, NHC and JHC are not supported anymore, but these-    -- fields are kept around so that we can still parse legacy .cabal-    -- files that have them.-    <*  knownField "jhc-options"-    <*  knownField "hugs-options"-    <*  knownField "nhc98-options"-  where-    extract :: CompilerFlavor -> ALens' BuildInfo [String]-    extract flavor = L.options . lookupLens flavor--profOptionsFieldGrammar-    :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String))-    => g BuildInfo (PerCompilerFlavor [String])-profOptionsFieldGrammar = PerCompilerFlavor-    <$> monoidalFieldAla "ghc-prof-options"   (alaList' NoCommaFSep Token') (extract GHC)-    <*> monoidalFieldAla "ghcjs-prof-options" (alaList' NoCommaFSep Token') (extract GHCJS)-  where-    extract :: CompilerFlavor -> ALens' BuildInfo [String]-    extract flavor = L.profOptions . lookupLens flavor--sharedOptionsFieldGrammar-    :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String))-    => g BuildInfo (PerCompilerFlavor [String])-sharedOptionsFieldGrammar = PerCompilerFlavor-    <$> monoidalFieldAla "ghc-shared-options"   (alaList' NoCommaFSep Token') (extract GHC)-    <*> monoidalFieldAla "ghcjs-shared-options" (alaList' NoCommaFSep Token') (extract GHCJS)-  where-    extract :: CompilerFlavor -> ALens' BuildInfo [String]-    extract flavor = L.sharedOptions . lookupLens flavor--lookupLens :: (Functor f, Monoid v) => CompilerFlavor -> LensLike' f (PerCompilerFlavor v) v-lookupLens k f p@(PerCompilerFlavor ghc ghcjs)-    | k == GHC   = (\n -> PerCompilerFlavor n ghcjs) <$> f ghc-    | k == GHCJS = (\n -> PerCompilerFlavor ghc n) <$> f ghcjs-    | otherwise  = p <$ f mempty------------------------------------------------------------------------------------ Flag----------------------------------------------------------------------------------flagFieldGrammar-    :: (FieldGrammar c g, Applicative (g PackageFlag))-    =>  FlagName -> g PackageFlag PackageFlag-flagFieldGrammar name = MkPackageFlag name-    <$> freeTextFieldDef    "description"          L.flagDescription-    <*> booleanFieldDef     "default"              L.flagDefault     True-    <*> booleanFieldDef     "manual"               L.flagManual      False-{-# SPECIALIZE flagFieldGrammar :: FlagName -> ParsecFieldGrammar' PackageFlag #-}-{-# SPECIALIZE flagFieldGrammar :: FlagName -> PrettyFieldGrammar' PackageFlag #-}------------------------------------------------------------------------------------ SourceRepo----------------------------------------------------------------------------------sourceRepoFieldGrammar-    :: (FieldGrammar c g, Applicative (g SourceRepo), c (Identity RepoType), c Token, c FilePathNT)-    => RepoKind -> g SourceRepo SourceRepo-sourceRepoFieldGrammar kind = SourceRepo kind-    <$> optionalField    "type"                L.repoType-    <*> freeTextField    "location"            L.repoLocation-    <*> optionalFieldAla "module"   Token      L.repoModule-    <*> optionalFieldAla "branch"   Token      L.repoBranch-    <*> optionalFieldAla "tag"      Token      L.repoTag-    <*> optionalFieldAla "subdir"   FilePathNT L.repoSubdir-{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> ParsecFieldGrammar' SourceRepo #-}-{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> PrettyFieldGrammar' SourceRepo #-}------------------------------------------------------------------------------------ SetupBuildInfo----------------------------------------------------------------------------------setupBInfoFieldGrammar-    :: (FieldGrammar c g, Functor (g SetupBuildInfo), c (List CommaVCat (Identity Dependency) Dependency))-    => Bool -> g SetupBuildInfo SetupBuildInfo-setupBInfoFieldGrammar def = flip SetupBuildInfo def-    <$> monoidalFieldAla "setup-depends" (alaList CommaVCat) L.setupDepends-{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-}-{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> PrettyFieldGrammar' SetupBuildInfo #-}------------------------------------------------------------------------------------ Define how field values should be formatted for 'pretty'.----------------------------------------------------------------------------------formatDependencyList :: [Dependency] -> List CommaVCat (Identity Dependency) Dependency-formatDependencyList = alaList CommaVCat--formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin-formatMixinList = alaList CommaVCat--formatExtraSourceFiles :: [FilePath] -> List VCat FilePathNT FilePath-formatExtraSourceFiles = alaList' VCat FilePathNT--formatExposedModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName-formatExposedModules = alaList' VCat MQuoted--formatHsSourceDirs :: [SymbolicPath PackageDir SourceDir] -> List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)-formatHsSourceDirs = alaList FSep--formatOtherExtensions :: [Extension] -> List FSep (MQuoted Extension) Extension-formatOtherExtensions = alaList' FSep MQuoted--formatOtherModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName-formatOtherModules = alaList' VCat MQuoted------------------------------------------------------------------------------------ newtypes------------------------------------------------------------------------------------ | Compat FilePath accepts empty file path,--- but issues a warning.------ There are simply too many (~1200) package definition files------ @--- license-file: ""--- @------ and------ @--- data-dir: ""--- @------ across Hackage to outrule them completely.--- I suspect some of them are generated (e.g. formatted) by machine.----newtype CompatFilePath = CompatFilePath { getCompatFilePath :: FilePath } -- TODO: Change to use SymPath--instance Newtype String CompatFilePath--instance Parsec CompatFilePath where-    parsec = do-        token <- parsecToken-        if null token-        then do-            parsecWarning PWTEmptyFilePath "empty FilePath"-            return (CompatFilePath "")-        else return (CompatFilePath token)--instance Pretty CompatFilePath where-    pretty = showToken . getCompatFilePath--newtype CompatLicenseFile = CompatLicenseFile { getCompatLicenseFile :: [SymbolicPath PackageDir LicenseFile] }--instance Newtype [SymbolicPath PackageDir LicenseFile] CompatLicenseFile---- TODO-instance Parsec CompatLicenseFile where-    parsec = emptyToken <|> CompatLicenseFile . unpack' (alaList FSep) <$> parsec-      where-        emptyToken = P.try $ do-            token <- parsecToken-            if null token-            then return (CompatLicenseFile [])-            else P.unexpected "non-empty-token"--instance Pretty CompatLicenseFile where-    pretty = pretty . pack' (alaList FSep) . getCompatLicenseFile------------------------------------------------------------------------------------ vim syntax definitions------------------------------------------------------------------------------------ | '_syntaxFieldNames' and '_syntaxExtensions'--- are for generating VIM syntax file definitions.----_syntaxFieldNames :: IO ()-_syntaxFieldNames = sequence_-    [ BS8.putStrLn $ " \\ " <> n-    | n <- nub $ sort $ mconcat-        [ fieldGrammarKnownFieldList packageDescriptionFieldGrammar-        , fieldGrammarKnownFieldList $ libraryFieldGrammar LMainLibName-        , fieldGrammarKnownFieldList $ executableFieldGrammar "exe"-        , fieldGrammarKnownFieldList $ foreignLibFieldGrammar "flib"-        , fieldGrammarKnownFieldList testSuiteFieldGrammar-        , fieldGrammarKnownFieldList benchmarkFieldGrammar-        , fieldGrammarKnownFieldList $ flagFieldGrammar (error "flagname")-        , fieldGrammarKnownFieldList $ sourceRepoFieldGrammar (error "repokind")-        , fieldGrammarKnownFieldList $ setupBInfoFieldGrammar True-        ]-    ]--_syntaxExtensions :: IO ()-_syntaxExtensions = sequence_-    [ putStrLn $ "  \\ " <> e-    | e <- ["Safe","Trustworthy","Unsafe"]-        ++ es-        ++ map ("No"++) es-    ]-  where-    es = nub $ sort-          [ prettyShow e-          | e <- [ minBound .. maxBound ]-          , e `notElem` [Safe,Unsafe,Trustworthy]-          ]
− src/Distribution/PackageDescription/Parsec.hs 
@@ -1,980 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE Rank2Types          #-}-{-# LANGUAGE ScopedTypeVariables #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription.Parsec--- Copyright   :  Isaac Jones 2003-2005--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This defined parsers and partial pretty printers for the @.cabal@ format.--module Distribution.PackageDescription.Parsec (-    -- * Package descriptions-    readGenericPackageDescription,-    parseGenericPackageDescription,-    parseGenericPackageDescriptionMaybe,--    -- ** Parsing-    ParseResult,-    runParseResult,--    -- * New-style spec-version-    scanSpecVersion,--    -- ** Supplementary build information-    readHookedBuildInfo,-    parseHookedBuildInfo,-    ) where--import Distribution.Compat.Prelude-import Prelude ()--import Control.Monad.State.Strict                    (StateT, execStateT)-import Control.Monad.Trans.Class                     (lift)-import Distribution.CabalSpecVersion-import Distribution.Compat.Lens-import Distribution.FieldGrammar-import Distribution.FieldGrammar.Parsec              (NamelessField (..))-import Distribution.Fields.ConfVar                   (parseConditionConfVar)-import Distribution.Fields.Field                     (FieldName, getName)-import Distribution.Fields.LexerMonad                (LexWarning, toPWarnings)-import Distribution.Fields.Parser-import Distribution.Fields.ParseResult-import Distribution.PackageDescription-import Distribution.PackageDescription.Configuration (freeVars, transformAllBuildInfos)-import Distribution.PackageDescription.FieldGrammar-import Distribution.PackageDescription.Quirks        (patchQuirks)-import Distribution.Parsec                           (parsec, simpleParsecBS)-import Distribution.Parsec.FieldLineStream           (fieldLineStreamFromBS)-import Distribution.Parsec.Position                  (Position (..), zeroPos)-import Distribution.Parsec.Warning                   (PWarnType (..))-import Distribution.Pretty                           (prettyShow)-import Distribution.Simple.Utils                     (fromUTF8BS, toUTF8BS)-import Distribution.Utils.Generic                    (breakMaybe, unfoldrM, validateUTF8)-import Distribution.Verbosity                        (Verbosity)-import Distribution.Version                          (Version, mkVersion, versionNumbers)--import qualified Data.ByteString                                   as BS-import qualified Data.ByteString.Char8                             as BS8-import qualified Data.Map.Strict                                   as Map-import qualified Data.Set                                          as Set-import qualified Distribution.Compat.Newtype                       as Newtype-import qualified Distribution.Compat.NonEmptySet                   as NES-import qualified Distribution.Types.BuildInfo.Lens                 as L-import qualified Distribution.Types.Executable.Lens                as L-import qualified Distribution.Types.ForeignLib.Lens                as L-import qualified Distribution.Types.GenericPackageDescription.Lens as L-import qualified Distribution.Types.PackageDescription.Lens        as L-import qualified Distribution.Types.SetupBuildInfo.Lens            as L-import qualified Text.Parsec                                       as P---- ------------------------------------------------------------------ Parsing--- ------------------------------------------------------------------- | Parse the given package file.-readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription-readGenericPackageDescription = readAndParseFile parseGenericPackageDescription----------------------------------------------------------------------------------- | Parses the given file into a 'GenericPackageDescription'.------ In Cabal 1.2 the syntax for package descriptions was changed to a format--- with sections and possibly indented property descriptions.----parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription-parseGenericPackageDescription bs = do-    -- set scanned version-    setCabalSpecVersion ver--    csv <- case ver of-        -- if we get too new version, fail right away-        Just v -> case cabalSpecFromVersionDigits (versionNumbers v) of-            Just csv -> return (Just csv)-            Nothing  -> parseFatalFailure zeroPos $-                "Unsupported cabal-version " ++ prettyShow v ++ ". See https://github.com/haskell/cabal/issues/4899."-        _ -> pure Nothing--    case readFields' bs'' of-        Right (fs, lexWarnings) -> do-            when patched $-                parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file"-            -- UTF8 is validated in a prepass step, afterwards parsing is lenient.-            parseGenericPackageDescription' csv lexWarnings invalidUtf8 fs-        -- TODO: better marshalling of errors-        Left perr -> parseFatalFailure pos (show perr) where-            ppos = P.errorPos perr-            pos  = Position (P.sourceLine ppos) (P.sourceColumn ppos)-  where-    (patched, bs') = patchQuirks bs-    ver = scanSpecVersion bs'--    invalidUtf8 = validateUTF8 bs'--    -- if there are invalid utf8 characters, we make the bytestring valid.-    bs'' = case invalidUtf8 of-        Nothing -> bs'-        Just _  -> toUTF8BS (fromUTF8BS bs')----- | 'Maybe' variant of 'parseGenericPackageDescription'-parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription-parseGenericPackageDescriptionMaybe =-    either (const Nothing) Just . snd . runParseResult . parseGenericPackageDescription--fieldlinesToBS :: [FieldLine ann] -> BS.ByteString-fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)---- Monad in which sections are parsed-type SectionParser = StateT SectionS ParseResult---- | State of section parser-data SectionS = SectionS-    { _stateGpd           :: !GenericPackageDescription-    , _stateCommonStanzas :: !(Map String CondTreeBuildInfo)-    }--stateGpd :: Lens' SectionS GenericPackageDescription-stateGpd f (SectionS gpd cs) = (\x -> SectionS x cs) <$> f gpd-{-# INLINE stateGpd #-}--stateCommonStanzas :: Lens' SectionS (Map String CondTreeBuildInfo)-stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs-{-# INLINE stateCommonStanzas #-}---- Note [Accumulating parser]------ This parser has two "states":--- * first we parse fields of PackageDescription--- * then we parse sections (libraries, executables, etc)-parseGenericPackageDescription'-    :: Maybe CabalSpecVersion-    -> [LexWarning]-    -> Maybe Int-    -> [Field Position]-    -> ParseResult GenericPackageDescription-parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do-    parseWarnings (toPWarnings lexWarnings)-    for_ utf8WarnPos $ \pos ->-        parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos-    let (syntax, fs') = sectionizeFields fs-    let (fields, sectionFields) = takeFields fs'--    -- cabal-version-    specVer <- case scannedVer of-        Just v  -> return v-        Nothing -> case Map.lookup "cabal-version" fields >>= safeLast of-            Nothing                        -> return CabalSpecV1_0-            Just (MkNamelessField pos fls) -> do-                -- version will be parsed twice, therefore we parse without warnings.-                v <- withoutWarnings $-                    Newtype.unpack' SpecVersion <$>-                    -- Use version with || and && but before addition of ^>= and removal of -any-                    runFieldParser pos parsec CabalSpecV1_24 fls--                -- if it were at the beginning, scanner would found it-                when (v >= CabalSpecV2_2) $ parseFailure pos $-                    "cabal-version should be at the beginning of the file starting with spec version 2.2. " ++-                    "See https://github.com/haskell/cabal/issues/4899"--                return v--    -- reset cabal version, it might not be set-    let specVer' = mkVersion (cabalSpecToVersionDigits specVer)-    setCabalSpecVersion (Just specVer')--    -- Package description-    pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar--    -- Check that scanned and parsed versions match.-    unless (specVer == specVersion pd) $ parseFailure zeroPos $-        "Scanned and parsed cabal-versions don't match " ++-        prettyShow (SpecVersion specVer) ++ " /= " ++ prettyShow (SpecVersion (specVersion pd))--    maybeWarnCabalVersion syntax pd--    -- Sections-    let gpd = emptyGenericPackageDescription-            & L.packageDescription .~ pd-    gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty)--    let gpd2 = postProcessInternalDeps specVer gpd1-    checkForUndefinedFlags gpd2-    checkForUndefinedCustomSetup gpd2-    -- See nothunks test, without this deepseq we get (at least):-    -- Thunk in ThunkInfo {thunkContext = ["PackageIdentifier","PackageDescription","GenericPackageDescription"]}-    ---    -- TODO: re-benchmark, whether `deepseq` is important (both cabal-benchmarks and solver-benchmarks)-    -- TODO: remove the need for deepseq if `deepseq` in fact matters-    -- NOTE: IIRC it does affect (maximal) memory usage, which causes less GC pressure-    gpd2 `deepseq` return gpd2-  where-    safeLast :: [a] -> Maybe a-    safeLast = listToMaybe . reverse--    newSyntaxVersion :: CabalSpecVersion-    newSyntaxVersion = CabalSpecV1_2--    maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult ()-    maybeWarnCabalVersion syntax pkg-      | syntax == NewSyntax && specVersion pkg < newSyntaxVersion-      = parseWarning zeroPos PWTNewSyntax $-             "A package using section syntax must specify at least\n"-          ++ "'cabal-version: >= 1.2'."--    maybeWarnCabalVersion syntax pkg-      | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion-      = parseWarning zeroPos PWTOldSyntax $-             "A package using 'cabal-version: "-          ++ prettyShow (SpecVersion (specVersion pkg))-          ++ "' must use section syntax. See the Cabal user guide for details."--    maybeWarnCabalVersion _ _ = return ()--goSections :: CabalSpecVersion -> [Field Position] -> SectionParser ()-goSections specVer = traverse_ process-  where-    process (Field (Name pos name) _) =-        lift $ parseWarning pos PWTTrailingFields $-            "Ignoring trailing fields after sections: " ++ show name-    process (Section name args secFields) =-        parseSection name args secFields--    snoc x xs = xs ++ [x]--    hasCommonStanzas = specHasCommonStanzas specVer--    -- we need signature, because this is polymorphic, but not-closed-    parseCondTree'-        :: L.HasBuildInfo a-        => ParsecFieldGrammar' a       -- ^ grammar-        -> (BuildInfo -> a)-        -> Map String CondTreeBuildInfo  -- ^ common stanzas-        -> [Field Position]-        -> ParseResult (CondTree ConfVar [Dependency] a)-    parseCondTree' = parseCondTreeWithCommonStanzas specVer--    parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser ()-    parseSection (Name pos name) args fields-        | hasCommonStanzas == NoCommonStanzas, name == "common" = lift $ do-          parseWarning pos PWTUnknownSection $ "Ignoring section: common. You should set cabal-version: 2.2 or larger to use common stanzas."--        | name == "common" = do-            commonStanzas <- use stateCommonStanzas-            name' <- lift $ parseCommonName pos args-            biTree <- lift $ parseCondTree' buildInfoFieldGrammar id commonStanzas fields--            case Map.lookup name' commonStanzas of-                Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas-                Just _  -> lift $ parseFailure pos $-                    "Duplicate common stanza: " ++ name'--        | name == "library" && null args = do-            prev <- use $ stateGpd . L.condLibrary-            when (isJust prev) $ lift $ parseFailure pos $-                "Multiple main libraries; have you forgotten to specify a name for an internal library?"--            commonStanzas <- use stateCommonStanzas-            let name'' = LMainLibName-            lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields-            ---            -- TODO check that not set-            stateGpd . L.condLibrary ?= lib--        -- Sublibraries-        -- TODO: check cabal-version-        | name == "library" = do-            commonStanzas <- use stateCommonStanzas-            name' <- parseUnqualComponentName pos args-            let name'' = LSubLibName name'-            lib   <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields-            -- TODO check duplicate name here?-            stateGpd . L.condSubLibraries %= snoc (name', lib)--        -- TODO: check cabal-version-        | name == "foreign-library" = do-            commonStanzas <- use stateCommonStanzas-            name' <- parseUnqualComponentName pos args-            flib  <- lift $ parseCondTree' (foreignLibFieldGrammar name') (fromBuildInfo' name') commonStanzas fields--            let hasType ts = foreignLibType ts /= foreignLibType mempty-            unless (onAllBranches hasType flib) $ lift $ parseFailure pos $ concat-                [ "Foreign library " ++ show (prettyShow name')-                , " is missing required field \"type\" or the field "-                , "is not present in all conditional branches. The "-                , "available test types are: "-                , intercalate ", " (map prettyShow knownForeignLibTypes)-                ]--            -- TODO check duplicate name here?-            stateGpd . L.condForeignLibs %= snoc (name', flib)--        | name == "executable" = do-            commonStanzas <- use stateCommonStanzas-            name' <- parseUnqualComponentName pos args-            exe   <- lift $ parseCondTree' (executableFieldGrammar name') (fromBuildInfo' name') commonStanzas fields-            -- TODO check duplicate name here?-            stateGpd . L.condExecutables %= snoc (name', exe)--        | name == "test-suite" = do-            commonStanzas <- use stateCommonStanzas-            name'      <- parseUnqualComponentName pos args-            testStanza <- lift $ parseCondTree' testSuiteFieldGrammar (fromBuildInfo' name') commonStanzas fields-            testSuite  <- lift $ traverse (validateTestSuite pos) testStanza--            let hasType ts = testInterface ts /= testInterface mempty-            unless (onAllBranches hasType testSuite) $ lift $ parseFailure pos $ concat-                [ "Test suite " ++ show (prettyShow name')-                , " is missing required field \"type\" or the field "-                , "is not present in all conditional branches. The "-                , "available test types are: "-                , intercalate ", " (map prettyShow knownTestTypes)-                ]--            -- TODO check duplicate name here?-            stateGpd . L.condTestSuites %= snoc (name', testSuite)--        | name == "benchmark" = do-            commonStanzas <- use stateCommonStanzas-            name'       <- parseUnqualComponentName pos args-            benchStanza <- lift $ parseCondTree' benchmarkFieldGrammar (fromBuildInfo' name') commonStanzas fields-            bench       <- lift $ traverse (validateBenchmark pos) benchStanza--            let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty-            unless (onAllBranches hasType bench) $ lift $ parseFailure pos $ concat-                [ "Benchmark " ++ show (prettyShow name')-                , " is missing required field \"type\" or the field "-                , "is not present in all conditional branches. The "-                , "available benchmark types are: "-                , intercalate ", " (map prettyShow knownBenchmarkTypes)-                ]--            -- TODO check duplicate name here?-            stateGpd . L.condBenchmarks %= snoc (name', bench)--        | name == "flag" = do-            name'  <- parseNameBS pos args-            name'' <- lift $ runFieldParser' [pos] parsec specVer (fieldLineStreamFromBS name') `recoverWith` mkFlagName ""-            flag   <- lift $ parseFields specVer fields (flagFieldGrammar name'')-            -- Check default flag-            stateGpd . L.genPackageFlags %= snoc flag--        | name == "custom-setup" && null args = do-            sbi <- lift $ parseFields specVer fields  (setupBInfoFieldGrammar False)-            stateGpd . L.packageDescription . L.setupBuildInfo ?= sbi--        | name == "source-repository" = do-            kind <- lift $ case args of-                [SecArgName spos secName] ->-                    runFieldParser' [spos] parsec specVer (fieldLineStreamFromBS secName) `recoverWith` RepoHead-                [] -> do-                    parseFailure pos "'source-repository' requires exactly one argument"-                    pure RepoHead-                _ -> do-                    parseFailure pos $ "Invalid source-repository kind " ++ show args-                    pure RepoHead--            sr <- lift $ parseFields specVer fields (sourceRepoFieldGrammar kind)-            stateGpd . L.packageDescription . L.sourceRepos %= snoc sr--        | otherwise = lift $-            parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name--parseName :: Position -> [SectionArg Position] -> SectionParser String-parseName pos args = fromUTF8BS <$> parseNameBS pos args--parseNameBS :: Position -> [SectionArg Position] -> SectionParser BS.ByteString--- TODO: use strict parser-parseNameBS pos args = case args of-    [SecArgName _pos secName] ->-         pure secName-    [SecArgStr _pos secName] ->-         pure secName-    [] -> do-         lift $ parseFailure pos "name required"-         pure ""-    _ -> do-         -- TODO: pretty print args-         lift $ parseFailure pos $ "Invalid name " ++ show args-         pure ""--parseCommonName :: Position -> [SectionArg Position] -> ParseResult String-parseCommonName pos args = case args of-    [SecArgName _pos secName] ->-         pure $ fromUTF8BS secName-    [SecArgStr _pos secName] ->-         pure $ fromUTF8BS secName-    [] -> do-         parseFailure pos $ "name required"-         pure ""-    _ -> do-         -- TODO: pretty print args-         parseFailure pos $ "Invalid name " ++ show args-         pure ""---- TODO: avoid conversion to 'String'.-parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName-parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args---- | Parse a non-recursive list of fields.-parseFields-    :: CabalSpecVersion-    -> [Field Position] -- ^ fields to be parsed-    -> ParsecFieldGrammar' a-    -> ParseResult a-parseFields v fields grammar = do-    let (fs0, ss) = partitionFields fields-    traverse_ (traverse_ warnInvalidSubsection) ss-    parseFieldGrammar v fs0 grammar--warnInvalidSubsection :: Section Position -> ParseResult ()-warnInvalidSubsection (MkSection (Name pos name) _ _) =-    void $ parseFailure pos $ "invalid subsection " ++ show name--parseCondTree-    :: forall a. L.HasBuildInfo a-    => CabalSpecVersion-    -> HasElif                        -- ^ accept @elif@-    -> ParsecFieldGrammar' a          -- ^ grammar-    -> Map String CondTreeBuildInfo   -- ^ common stanzas-    -> (BuildInfo -> a)               -- ^ constructor from buildInfo-    -> (a -> [Dependency])            -- ^ condition extractor-    -> [Field Position]-    -> ParseResult (CondTree ConfVar [Dependency] a)-parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go-  where-    go fields0 = do-        (fields, endo) <--            if v >= CabalSpecV3_0-            then processImports v fromBuildInfo commonStanzas fields0-            else traverse (warnImport v) fields0 >>= \fields1 -> return (catMaybes fields1, id)--        let (fs, ss) = partitionFields fields-        x <- parseFieldGrammar v fs grammar-        branches <- concat <$> traverse parseIfs ss-        return $ endo $ CondNode x (cond x) branches--    parseIfs :: [Section Position] -> ParseResult [CondBranch ConfVar [Dependency] a]-    parseIfs [] = return []-    parseIfs (MkSection (Name _ name) test fields : sections) | name == "if" = do-        test' <- parseConditionConfVar test-        fields' <- go fields-        (elseFields, sections') <- parseElseIfs sections-        return (CondBranch test' fields' elseFields : sections')-    parseIfs (MkSection (Name pos name) _ _ : sections) = do-        parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name-        parseIfs sections--    parseElseIfs-        :: [Section Position]-        -> ParseResult (Maybe (CondTree ConfVar [Dependency] a), [CondBranch ConfVar [Dependency] a])-    parseElseIfs [] = return (Nothing, [])-    parseElseIfs (MkSection (Name pos name) args fields : sections) | name == "else" = do-        unless (null args) $-            parseFailure pos $ "`else` section has section arguments " ++ show args-        elseFields <- go fields-        sections' <- parseIfs sections-        return (Just elseFields, sections')--    parseElseIfs (MkSection (Name _ name) test fields : sections) | hasElif == HasElif, name == "elif" = do-        test' <- parseConditionConfVar test-        fields' <- go fields-        (elseFields, sections') <- parseElseIfs sections-        -- we parse an empty 'Fields', to get empty value for a node-        a <- parseFieldGrammar v mempty grammar-        return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections')--    parseElseIfs (MkSection (Name pos name) _ _ : sections) | name == "elif" = do-        parseWarning pos PWTInvalidSubsection $ "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals."-        (,) Nothing <$> parseIfs sections--    parseElseIfs sections = (,) Nothing <$> parseIfs sections--{- Note [Accumulating parser]--Note: Outdated a bit--In there parser, @'FieldDescr' a@ is transformed into @Map FieldName (a ->-FieldParser a)@.  The weird value is used because we accumulate structure of-@a@ by folding over the fields.  There are various reasons for that:--* Almost all fields are optional--* This is simple approach so declarative bi-directional format (parsing and-printing) of structure could be specified (list of @'FieldDescr' a@)--* There are surface syntax fields corresponding to single field in the file:-  @license-file@ and @license-files@--* This is quite safe approach.--When/if we re-implement the parser to support formatting preservging roundtrip-with new AST, this all need to be rewritten.--}------------------------------------------------------------------------------------ Common stanzas------------------------------------------------------------------------------------ $commonStanzas------ [Note: Common stanzas]------ In Cabal 2.2 we support simple common stanzas:------ * Commons stanzas define 'BuildInfo'------ * import "fields" can only occur at top of other stanzas (think: imports)------ In particular __there aren't__------ * implicit stanzas------ * More specific common stanzas (executable, test-suite).--------- The approach uses the fact that 'BuildInfo' is a 'Monoid':------ @--- mergeCommonStanza' :: HasBuildInfo comp => BuildInfo -> comp -> comp--- mergeCommonStanza' bi = over L.BuildInfo (bi <>)--- @------ Real 'mergeCommonStanza' is more complicated as we have to deal with--- conditional trees.------ The approach is simple, and have good properties:------ * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them.----type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo---- | Create @a@ from 'BuildInfo'.--- This class is used to implement common stanza parsing.------ Law: @view buildInfo . fromBuildInfo = id@------ This takes name, as 'FieldGrammar's take names too.-class L.HasBuildInfo a => FromBuildInfo a where-    fromBuildInfo' :: UnqualComponentName -> BuildInfo -> a--libraryFromBuildInfo :: LibraryName -> BuildInfo -> Library-libraryFromBuildInfo n bi = emptyLibrary-    { libName       = n-    , libVisibility = case n of-        LMainLibName  -> LibraryVisibilityPublic-        LSubLibName _ -> LibraryVisibilityPrivate-    , libBuildInfo  = bi-    }--instance FromBuildInfo BuildInfo  where fromBuildInfo' _ = id-instance FromBuildInfo ForeignLib where fromBuildInfo' n bi = set L.foreignLibName n $ set L.buildInfo bi emptyForeignLib-instance FromBuildInfo Executable where fromBuildInfo' n bi = set L.exeName        n $ set L.buildInfo bi emptyExecutable--instance FromBuildInfo TestSuiteStanza where-    fromBuildInfo' _ bi = TestSuiteStanza Nothing Nothing Nothing bi--instance FromBuildInfo BenchmarkStanza where-    fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi--parseCondTreeWithCommonStanzas-    :: forall a. L.HasBuildInfo a-    => CabalSpecVersion-    -> ParsecFieldGrammar' a       -- ^ grammar-    -> (BuildInfo -> a)              -- ^ construct fromBuildInfo-    -> Map String CondTreeBuildInfo  -- ^ common stanzas-    -> [Field Position]-    -> ParseResult (CondTree ConfVar [Dependency] a)-parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas fields = do-    (fields', endo) <- processImports v fromBuildInfo commonStanzas fields-    x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo (view L.targetBuildDepends) fields'-    return (endo x)-  where-    hasElif = specHasElif v--processImports-    :: forall a. L.HasBuildInfo a-    => CabalSpecVersion-    -> (BuildInfo -> a)              -- ^ construct fromBuildInfo-    -> Map String CondTreeBuildInfo  -- ^ common stanzas-    -> [Field Position]-    -> ParseResult ([Field Position], CondTree ConfVar [Dependency] a -> CondTree ConfVar [Dependency] a)-processImports v fromBuildInfo commonStanzas = go []-  where-    hasCommonStanzas = specHasCommonStanzas v--    getList' :: List CommaFSep Token String -> [String]-    getList' = Newtype.unpack--    go acc (Field (Name pos name) _ : fields) | name == "import", hasCommonStanzas == NoCommonStanzas = do-        parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas"-        go acc fields-    -- supported:-    go acc (Field (Name pos name) fls : fields) | name == "import" = do-        names <- getList' <$> runFieldParser pos parsec v fls-        names' <- for names $ \commonName ->-            case Map.lookup commonName commonStanzas of-                Nothing -> do-                    parseFailure pos $ "Undefined common stanza imported: " ++ commonName-                    pure Nothing-                Just commonTree ->-                    pure (Just commonTree)--        go (acc ++ catMaybes names') fields--    -- parse actual CondTree-    go acc fields = do-        fields' <- catMaybes <$> traverse (warnImport v) fields-        pure $ (fields', \x -> foldr (mergeCommonStanza fromBuildInfo) x acc)---- | Warn on "import" fields, also map to Maybe, so errorneous fields can be filtered-warnImport :: CabalSpecVersion -> Field Position -> ParseResult (Maybe (Field Position))-warnImport v (Field (Name pos name) _) | name ==  "import" = do-    if specHasCommonStanzas v == NoCommonStanzas-    then parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas"-    else parseWarning pos PWTUnknownField "Unknown field: import. Common stanza imports should be at the top of the enclosing section"-    return Nothing-warnImport _ f = pure (Just f)--mergeCommonStanza-    :: L.HasBuildInfo a-    => (BuildInfo -> a)-    -> CondTree ConfVar [Dependency] BuildInfo-    -> CondTree ConfVar [Dependency] a-    -> CondTree ConfVar [Dependency] a-mergeCommonStanza fromBuildInfo (CondNode bi _ bis) (CondNode x _ cs) =-    CondNode x' (x' ^. L.targetBuildDepends) cs'-  where-    -- new value is old value with buildInfo field _prepended_.-    x' = x & L.buildInfo %~ (bi <>)--    -- tree components are appended together.-    cs' = map (fmap fromBuildInfo) bis ++ cs------------------------------------------------------------------------------------ Branches------------------------------------------------------------------------------------ Check that a property holds on all branches of a condition tree-onAllBranches :: forall v c a. Monoid a => (a -> Bool) -> CondTree v c a -> Bool-onAllBranches p = go mempty-  where-    -- If the current level of the tree satisfies the property, then we are-    -- done. If not, then one of the conditional branches below the current node-    -- must satisfy it. Each node may have multiple immediate children; we only-    -- one need one to satisfy the property because the configure step uses-    -- 'mappend' to join together the results of flag resolution.-    go :: a -> CondTree v c a -> Bool-    go acc ct = let acc' = acc `mappend` condTreeData ct-                in p acc' || any (goBranch acc') (condTreeComponents ct)--    -- Both the 'true' and the 'false' block must satisfy the property.-    goBranch :: a -> CondBranch v c a -> Bool-    goBranch _   (CondBranch _ _ Nothing) = False-    goBranch acc (CondBranch _ t (Just e))  = go acc t && go acc e------------------------------------------------------------------------------------ Post parsing checks------------------------------------------------------------------------------------ | Check that we ------ * don't use undefined flags (very bad)--- * define flags which are unused (just bad)----checkForUndefinedFlags :: GenericPackageDescription -> ParseResult ()-checkForUndefinedFlags gpd = do-    let definedFlags, usedFlags :: Set.Set FlagName-        definedFlags = toSetOf (L.genPackageFlags . traverse . getting flagName) gpd-        usedFlags    = getConst $ L.allCondTrees f gpd--    -- Note: we can check for defined, but unused flags here too.-    unless (usedFlags `Set.isSubsetOf` definedFlags) $ parseFailure zeroPos $-        "These flags are used without having been defined: " ++-        intercalate ", " [ unFlagName fn | fn <- Set.toList $ usedFlags `Set.difference` definedFlags ]-  where-    f :: CondTree ConfVar c a -> Const (Set.Set FlagName) (CondTree ConfVar c a)-    f ct = Const (Set.fromList (freeVars ct))---- | Since @cabal-version: 1.24@ one can specify @custom-setup@.--- Let us require it.----checkForUndefinedCustomSetup :: GenericPackageDescription -> ParseResult ()-checkForUndefinedCustomSetup gpd = do-    let pd  = packageDescription gpd-    let csv = specVersion pd--    when (buildType pd == Custom && isNothing (setupBuildInfo pd)) $-        when (csv >= CabalSpecV1_24) $ parseFailure zeroPos $-            "Since cabal-version: 1.24 specifying custom-setup section is mandatory"------------------------------------------------------------------------------------ Post processing of internal dependencies------------------------------------------------------------------------------------ Note [Dependencies on sublibraries]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ This is solution to https://github.com/haskell/cabal/issues/6083------ Before 'cabal-version: 3.0' we didn't have a syntax specially--- for referring to internal libraries. Internal library names--- shadowed the outside ones.------ Since 'cabal-version: 3.0' we have ability to write------     build-depends: some-package:its-sub-lib >=1.2.3------ This allows us to refer also to local packages by `this-package:sublib`.--- So since 'cabal-version: 3.4' to refer to *any*--- sublibrary we must use the two part syntax. Here's small table:------                   | pre-3.4             |      3.4 and after            |--- ------------------|---------------------|-------------------------------|--- pkg-name          | may refer to sublib | always refers to external pkg |--- pkg-name:sublib   | refers to sublib    | refers to sublib              |--- pkg-name:pkg-name | may refer to sublib | always refers to external pkg |------ In pre-3.4 case, if a package 'this-pkg' has a sublibrary 'pkg-name',--- all dependency definitions will refer to that sublirary.------ In 3.4 and after case, 'pkg-name' will always refer to external package,--- and to use internal library you have to say 'this-pkg:pkg-name'.------ In summary, In 3.4 and after, the internal names don't shadow,--- as there is an explicit syntax to refer to them,--- i.e. what you write is what you get;--- For pre-3.4 we post-process the file.------ Similarly, we process mixins.--- See https://github.com/haskell/cabal/issues/6281-----postProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription-postProcessInternalDeps specVer gpd-    | specVer >= CabalSpecV3_4 = gpd-    | otherwise                = transformAllBuildInfos transformBI transformSBI gpd-  where-    transformBI :: BuildInfo -> BuildInfo-    transformBI-        = over L.targetBuildDepends (concatMap transformD)-        . over L.mixins (map transformM)--    transformSBI :: SetupBuildInfo -> SetupBuildInfo-    transformSBI = over L.setupDepends (concatMap transformD)--    transformD :: Dependency -> [Dependency]-    transformD (Dependency pn vr ln)-        | uqn `Set.member` internalLibs-        , LMainLibName `NES.member` ln-        = case NES.delete LMainLibName ln of-            Nothing  -> [dep]-            Just ln' -> [dep, Dependency pn vr ln']-      where-        uqn = packageNameToUnqualComponentName pn-        dep = Dependency thisPn vr (NES.singleton (LSubLibName uqn))--    transformD d = [d]--    transformM :: Mixin -> Mixin-    transformM (Mixin pn LMainLibName incl)-        | uqn `Set.member` internalLibs-        = mkMixin thisPn (LSubLibName uqn) incl-      where-        uqn = packageNameToUnqualComponentName pn--    transformM m = m--    thisPn :: PackageName-    thisPn = pkgName (package (packageDescription gpd))--    internalLibs :: Set UnqualComponentName-    internalLibs = Set.fromList-        [ n-        | (n, _) <- condSubLibraries gpd-        ]------------------------------------------------------------------------------------ Old syntax------------------------------------------------------------------------------------ TODO: move to own module---- | "Sectionize" an old-style Cabal file.  A sectionized file has:------  * all global fields at the beginning, followed by------  * all flag declarations, followed by------  * an optional library section, and an arbitrary number of executable---    sections (in any order).------ The current implementation just gathers all library-specific fields--- in a library section and wraps all executable stanzas in an executable--- section.-sectionizeFields :: [Field ann] -> (Syntax, [Field ann])-sectionizeFields fs = case classifyFields fs of-    Just fields -> (OldSyntax, convert fields)-    Nothing     -> (NewSyntax, fs)-  where-    -- return 'Just' if all fields are simple fields-    classifyFields :: [Field ann] -> Maybe [(Name ann, [FieldLine ann])]-    classifyFields = traverse f-      where-        f (Field name fieldlines) = Just (name, fieldlines)-        f _                      = Nothing--    trim = BS.dropWhile isSpace' . BS.reverse . BS.dropWhile isSpace' . BS.reverse-    isSpace' = (== 32)--    convert :: [(Name ann, [FieldLine ann])] -> [Field ann]-    convert fields =-      let-        toField (name, ls) = Field name ls-        -- "build-depends" is a local field now.  To be backwards-        -- compatible, we still allow it as a global field in old-style-        -- package description files and translate it to a local field by-        -- adding it to every non-empty section-        (hdr0, exes0) = break ((=="executable") . getName . fst) fields-        (hdr, libfs0) = partition (not . (`elem` libFieldNames) . getName . fst) hdr0--        (deps, libfs) = partition ((== "build-depends") . getName . fst)-                                   libfs0--        exes = unfoldr toExe exes0-        toExe [] = Nothing-        toExe ((Name pos n, ls) : r)-          | n == "executable" =-              let (efs, r') = break ((== "executable") . getName . fst) r-              in Just (Section (Name pos "executable") [SecArgName pos $ trim $ fieldlinesToBS ls] (map toField $ deps ++ efs), r')-        toExe _ = error "unexpected input to 'toExe'"--        lib = case libfs of-            []                         -> []-            ((Name pos _,  _) : _) ->-                [Section (Name pos "library") [] (map toField $ deps ++ libfs)]--      in map toField hdr ++ lib ++ exes---- | See 'sectionizeFields'.-data Syntax = OldSyntax | NewSyntax-    deriving (Eq, Show)---- TODO:-libFieldNames :: [FieldName]-libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar LMainLibName)------------------------------------------------------------------------------------ Suplementary build information----------------------------------------------------------------------------------readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo-readHookedBuildInfo = readAndParseFile parseHookedBuildInfo--parseHookedBuildInfo :: BS.ByteString -> ParseResult HookedBuildInfo-parseHookedBuildInfo bs = case readFields' bs of-    Right (fs, lexWarnings) -> do-        parseHookedBuildInfo' lexWarnings fs-    -- TODO: better marshalling of errors-    Left perr -> parseFatalFailure zeroPos (show perr)--parseHookedBuildInfo'-    :: [LexWarning]-    -> [Field Position]-    -> ParseResult HookedBuildInfo-parseHookedBuildInfo' lexWarnings fs = do-    parseWarnings (toPWarnings lexWarnings)-    (mLibFields, exes) <- stanzas fs-    mLib <- parseLib mLibFields-    biExes <- traverse parseExe exes-    return (mLib, biExes)-  where-    parseLib :: Fields Position -> ParseResult (Maybe BuildInfo)-    parseLib fields-        | Map.null fields = pure Nothing-        | otherwise       = Just <$> parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar--    parseExe :: (UnqualComponentName, Fields Position) -> ParseResult (UnqualComponentName, BuildInfo)-    parseExe (n, fields) = do-        bi <- parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar-        pure (n, bi)--    stanzas :: [Field Position] -> ParseResult (Fields Position, [(UnqualComponentName, Fields Position)])-    stanzas fields = do-        let (hdr0, exes0) = breakMaybe isExecutableField fields-        hdr <- toFields hdr0-        exes <- unfoldrM (traverse toExe) exes0-        pure (hdr, exes)--    toFields :: [Field Position] -> ParseResult (Fields Position)-    toFields fields = do-        let (fields', ss) = partitionFields fields-        traverse_ (traverse_ warnInvalidSubsection) ss-        pure fields'--    toExe-        :: ([FieldLine Position], [Field Position])-        -> ParseResult ((UnqualComponentName, Fields Position), Maybe ([FieldLine Position], [Field Position]))-    toExe (fss, fields) = do-        name <- runFieldParser zeroPos parsec cabalSpecLatest fss-        let (hdr0, rest) = breakMaybe isExecutableField fields-        hdr <- toFields hdr0-        pure ((name, hdr), rest)--    isExecutableField (Field (Name _ name) fss)-        | name == "executable" = Just fss-        | otherwise            = Nothing-    isExecutableField _ = Nothing------------------------------------------------------------------------------------ Scan of spec version------------------------------------------------------------------------------------ | Quickly scan new-style spec-version------ A new-style spec-version declaration begins the .cabal file and--- follow the following case-insensitive grammar (expressed in--- RFC5234 ABNF):------ @--- newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-pec-version *WS------ spec-version               = NUM "." NUM [ "." NUM ]------ NUM    = DIGIT0 / DIGITP 1*DIGIT0--- DIGIT0 = %x30-39--- DIGITP = %x31-39--- WS = %20--- @----scanSpecVersion :: BS.ByteString -> Maybe Version-scanSpecVersion bs = do-    fstline':_ <- pure (BS8.lines bs)--    -- parse <newstyle-spec-version-decl>-    -- normalise: remove all whitespace, convert to lower-case-    let fstline = BS.map toLowerW8 $ BS.filter (/= 0x20) fstline'-    ["cabal-version",vers] <- pure (BS8.split ':' fstline)--    -- parse <spec-version>-    ---    -- This is currently more tolerant regarding leading 0 digits.-    ---    ver <- simpleParsecBS vers-    guard $ case versionNumbers ver of-              [_,_]   -> True-              [_,_,_] -> True-              _       -> False--    pure ver-  where-    -- | Translate ['A'..'Z'] to ['a'..'z']-    toLowerW8 :: Word8 -> Word8-    toLowerW8 w | 0x40 < w && w < 0x5b = w+0x20-                | otherwise            = w
− src/Distribution/PackageDescription/PrettyPrint.hs 
@@ -1,282 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription.PrettyPrint--- Copyright   :  Jürgen Nicklisch-Franken 2010--- License     :  BSD3------ Maintainer  : cabal-devel@haskell.org--- Stability   : provisional--- Portability : portable------ Pretty printing for cabal files-----------------------------------------------------------------------------------module Distribution.PackageDescription.PrettyPrint (-    -- * Generic package descriptions-    writeGenericPackageDescription,-    showGenericPackageDescription,-    ppGenericPackageDescription,--    -- * Package descriptions-     writePackageDescription,-     showPackageDescription,--     -- ** Supplementary build information-     writeHookedBuildInfo,-     showHookedBuildInfo,-) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.CabalSpecVersion-import Distribution.Fields.Pretty-import Distribution.Compat.Lens-import Distribution.PackageDescription-import Distribution.Pretty-import Distribution.Simple.Utils (writeFileAtomic, writeUTF8File)-import Distribution.FieldGrammar                     (PrettyFieldGrammar', prettyFieldGrammar)-import Distribution.PackageDescription.Configuration (transformAllBuildInfos)-import Distribution.PackageDescription.FieldGrammar-       (benchmarkFieldGrammar, buildInfoFieldGrammar, executableFieldGrammar, flagFieldGrammar, foreignLibFieldGrammar, libraryFieldGrammar,-       packageDescriptionFieldGrammar, setupBInfoFieldGrammar, sourceRepoFieldGrammar, testSuiteFieldGrammar)--import qualified Distribution.PackageDescription.FieldGrammar as FG-import qualified Distribution.Types.BuildInfo.Lens                 as L-import qualified Distribution.Types.SetupBuildInfo.Lens            as L--import Text.PrettyPrint (Doc, char, hsep, parens, text)--import qualified Data.ByteString.Lazy.Char8      as BS.Char8-import qualified Distribution.Compat.NonEmptySet as NES---- | Writes a .cabal file from a generic package description-writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO ()-writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg)---- | Writes a generic package description to a string-showGenericPackageDescription :: GenericPackageDescription -> String-showGenericPackageDescription gpd = showFields (const []) $ ppGenericPackageDescription v gpd-  where-    v = specVersion $ packageDescription gpd---- | Convert a generic package description to 'PrettyField's.-ppGenericPackageDescription :: CabalSpecVersion -> GenericPackageDescription -> [PrettyField ()]-ppGenericPackageDescription v gpd0 = concat-    [ ppPackageDescription v (packageDescription gpd)-    , ppSetupBInfo v (setupBuildInfo (packageDescription gpd))-    , ppGenPackageFlags v (genPackageFlags gpd)-    , ppCondLibrary v (condLibrary gpd)-    , ppCondSubLibraries v (condSubLibraries gpd)-    , ppCondForeignLibs v (condForeignLibs gpd)-    , ppCondExecutables v (condExecutables gpd)-    , ppCondTestSuites v (condTestSuites gpd)-    , ppCondBenchmarks v (condBenchmarks gpd)-    ]-  where-    gpd = preProcessInternalDeps (specVersion (packageDescription gpd0)) gpd0---ppPackageDescription :: CabalSpecVersion -> PackageDescription -> [PrettyField ()]-ppPackageDescription v pd =-    prettyFieldGrammar v packageDescriptionFieldGrammar pd-    ++ ppSourceRepos v (sourceRepos pd)--ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField ()]-ppSourceRepos = map . ppSourceRepo--ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField ()-ppSourceRepo v repo = PrettySection () "source-repository" [pretty kind] $-    prettyFieldGrammar v (sourceRepoFieldGrammar kind) repo-  where-    kind = repoKind repo--ppSetupBInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyField ()]-ppSetupBInfo _ Nothing = mempty-ppSetupBInfo v (Just sbi)-    | defaultSetupDepends sbi = mempty-    | otherwise = pure $ PrettySection () "custom-setup" [] $-        prettyFieldGrammar v (setupBInfoFieldGrammar False) sbi--ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField ()]-ppGenPackageFlags = map . ppFlag--ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField ()-ppFlag v flag@(MkPackageFlag name _ _ _)  = PrettySection () "flag" [ppFlagName name] $-    prettyFieldGrammar v (flagFieldGrammar name) flag--ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> [PrettyField ()]-ppCondTree2 v grammar = go-  where-    -- TODO: recognise elif opportunities-    go (CondNode it _ ifs) =-        prettyFieldGrammar v grammar it ++-        concatMap ppIf ifs--    ppIf (CondBranch c thenTree Nothing)---        | isEmpty thenDoc = mempty-        | otherwise       = [ppIfCondition c thenDoc]-      where-        thenDoc = go thenTree--    ppIf (CondBranch c thenTree (Just elseTree)) =-      -- See #6193-      [ ppIfCondition c (go thenTree)-      , PrettySection () "else" [] (go elseTree)-      ]--ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [PrettyField ()]-ppCondLibrary _ Nothing = mempty-ppCondLibrary v (Just condTree) = pure $ PrettySection () "library" [] $-    ppCondTree2 v (libraryFieldGrammar LMainLibName) condTree--ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> [PrettyField ()]-ppCondSubLibraries v libs =-    [ PrettySection () "library" [pretty n]-    $ ppCondTree2 v (libraryFieldGrammar $ LSubLibName n) condTree-    | (n, condTree) <- libs-    ]--ppCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> [PrettyField ()]-ppCondForeignLibs v flibs =-    [ PrettySection () "foreign-library" [pretty n]-    $ ppCondTree2 v (foreignLibFieldGrammar n) condTree-    | (n, condTree) <- flibs-    ]--ppCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> [PrettyField ()]-ppCondExecutables v exes =-    [ PrettySection () "executable" [pretty n]-    $ ppCondTree2 v (executableFieldGrammar n) condTree-    | (n, condTree) <- exes-    ]--ppCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> [PrettyField ()]-ppCondTestSuites v suites =-    [ PrettySection () "test-suite" [pretty n]-    $ ppCondTree2 v testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree)-    | (n, condTree) <- suites-    ]--ppCondBenchmarks :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> [PrettyField ()]-ppCondBenchmarks v suites =-    [ PrettySection () "benchmark" [pretty n]-    $ ppCondTree2 v benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree)-    | (n, condTree) <- suites-    ]--ppCondition :: Condition ConfVar -> Doc-ppCondition (Var x)                      = ppConfVar x-ppCondition (Lit b)                      = text (show b)-ppCondition (CNot c)                     = char '!' <<>> (ppCondition c)-ppCondition (COr c1 c2)                  = parens (hsep [ppCondition c1, text "||"-                                                         <+> ppCondition c2])-ppCondition (CAnd c1 c2)                 = parens (hsep [ppCondition c1, text "&&"-                                                         <+> ppCondition c2])-ppConfVar :: ConfVar -> Doc-ppConfVar (OS os)            = text "os"   <<>> parens (pretty os)-ppConfVar (Arch arch)        = text "arch" <<>> parens (pretty arch)-ppConfVar (PackageFlag name) = text "flag" <<>> parens (ppFlagName name)-ppConfVar (Impl c v)         = text "impl" <<>> parens (pretty c <+> pretty v)--ppFlagName :: FlagName -> Doc-ppFlagName                               = text . unFlagName--ppIfCondition :: Condition ConfVar -> [PrettyField ()] -> PrettyField ()-ppIfCondition c = PrettySection () "if" [ppCondition c]---- | @since 2.0.0.2-writePackageDescription :: FilePath -> PackageDescription -> IO ()-writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)----TODO: make this use section syntax--- add equivalent for GenericPackageDescription---- | @since 2.0.0.2-showPackageDescription :: PackageDescription -> String-showPackageDescription = showGenericPackageDescription . pdToGpd--pdToGpd :: PackageDescription -> GenericPackageDescription-pdToGpd pd = GenericPackageDescription-    { packageDescription = pd-    , gpdScannedVersion  = Nothing-    , genPackageFlags    = []-    , condLibrary        = mkCondTree <$> library pd-    , condSubLibraries   = mkCondTreeL <$> subLibraries pd-    , condForeignLibs    = mkCondTree' foreignLibName <$> foreignLibs pd-    , condExecutables    = mkCondTree' exeName <$> executables pd-    , condTestSuites     = mkCondTree' testName <$> testSuites pd-    , condBenchmarks     = mkCondTree' benchmarkName <$> benchmarks pd-    }-  where-    -- We set CondTree's [Dependency] to an empty list, as it-    -- is not pretty printed anyway.-    mkCondTree  x = CondNode x [] []-    mkCondTreeL l = (fromMaybe (mkUnqualComponentName "") (libraryNameString (libName l)), CondNode l [] [])--    mkCondTree'-        :: (a -> UnqualComponentName)-        -> a -> (UnqualComponentName, CondTree ConfVar [Dependency] a)-    mkCondTree' f x = (f x, CondNode x [] [])------------------------------------------------------------------------------------ Internal libs------------------------------------------------------------------------------------ See Note [Dependencies on sublibraries] in Distribution.PackageDescription.Parsec----preProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription-preProcessInternalDeps specVer gpd-    | specVer >= CabalSpecV3_4 = gpd-    | otherwise                = transformAllBuildInfos transformBI transformSBI gpd-  where-    transformBI :: BuildInfo -> BuildInfo-    transformBI-        = over L.targetBuildDepends (concatMap transformD)-        . over L.mixins (map transformM)--    transformSBI :: SetupBuildInfo -> SetupBuildInfo-    transformSBI = over L.setupDepends (concatMap transformD)--    transformD :: Dependency -> [Dependency]-    transformD (Dependency pn vr ln)-        | pn == thisPn-        = if LMainLibName `NES.member` ln-          then Dependency thisPn vr mainLibSet : sublibs-          else sublibs-      where-        sublibs =-            [ Dependency (unqualComponentNameToPackageName uqn) vr mainLibSet-            | LSubLibName uqn <- NES.toList ln-            ]--    transformD d = [d]--    transformM :: Mixin -> Mixin-    transformM (Mixin pn (LSubLibName uqn) inc)-        | pn == thisPn-        = mkMixin (unqualComponentNameToPackageName uqn) LMainLibName inc-    transformM m = m--    thisPn :: PackageName-    thisPn = pkgName (package (packageDescription gpd))------------------------------------------------------------------------------------ HookedBuildInfo------------------------------------------------------------------------------------ | @since 2.0.0.2-writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()-writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack-                             . showHookedBuildInfo---- | @since 2.0.0.2-showHookedBuildInfo :: HookedBuildInfo -> String-showHookedBuildInfo (mb_lib_bi, ex_bis) = showFields (const []) $-    maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar) mb_lib_bi ++-    [ PrettySection () "executable:" [pretty name]-    $ prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar bi-    | (name, bi) <- ex_bis-    ]
− src/Distribution/PackageDescription/Quirks.hs 
@@ -1,340 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes        #-}--- |------ @since 2.2.0.0-module Distribution.PackageDescription.Quirks (patchQuirks) where--import Distribution.Compat.Prelude-import Distribution.Utils.MD5-import GHC.Fingerprint             (Fingerprint (..))-import Prelude ()--import qualified Data.ByteString as BS-import qualified Data.Map        as Map---- | Patch legacy @.cabal@ file contents to allow parsec parser to accept--- all of Hackage.------ Bool part of the result tells whether the output is modified.------ @since 2.2.0.0-patchQuirks :: BS.ByteString -> (Bool, BS.ByteString)-patchQuirks bs = case Map.lookup (BS.take 256 bs, md5 bs) patches of-    Nothing -> (False, bs)-    Just (post, f)-        | post /= md5 output -> (False, bs)-        | otherwise          -> (True, output)-      where-        output = f bs---- | 'patches' contains first 256 bytes, pre- and post-fingerprints and a patch function.-patches :: Map.Map (BS.ByteString, Fingerprint) (Fingerprint, BS.ByteString -> BS.ByteString)-patches = Map.fromList-    -- http://hackage.haskell.org/package/unicode-transforms-0.3.3-    -- other-modules: .-    -- ReadP assumed dot is empty line-    [ mk "-- This file has been generated from package.yaml by hpack version 0.17.0.\n--\n-- see: https://github.com/sol/hpack\n\nname:                unicode-transforms\nversion:             0.3.3\nsynopsis:            Unicode normalization\ndescription:         Fast Unic"-         (Fingerprint 15958160436627155571 10318709190730872881)-         (Fingerprint 11008465475756725834 13815629925116264363)-         (bsRemove "  other-modules:\n      .\n") -- TODO: remove traling \n to test structural-diff-    -- http://hackage.haskell.org/package/DSTM-0.1.2-    -- http://hackage.haskell.org/package/DSTM-0.1.1-    -- http://hackage.haskell.org/package/DSTM-0.1-    -- Other Modules: no dash-    -- ReadP parsed as section-    , mk "Name: DSTM\nVersion: 0.1.2\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed "-         (Fingerprint 6919263071548559054 9050746360708965827)-         (Fingerprint 17015177514298962556 11943164891661867280)-         (bsReplace "Other modules:" "-- ")-    , mk "Name: DSTM\nVersion: 0.1.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed "-         (Fingerprint 17313105789069667153 9610429408495338584)-         (Fingerprint 17250946493484671738 17629939328766863497)-         (bsReplace "Other modules:" "-- ")-    , mk "Name: DSTM\nVersion: 0.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed sy"-         (Fingerprint 10502599650530614586 16424112934471063115)-         (Fingerprint 13562014713536696107 17899511905611879358)-         (bsReplace "Other modules:" "-- ")-    -- http://hackage.haskell.org/package/control-monad-exception-mtl-0.10.3-    , mk "name: control-monad-exception-mtl\nversion: 0.10.3\nCabal-Version:  >= 1.10\nbuild-type: Simple\nlicense: PublicDomain\nauthor: Pepe Iborra\nmaintainer: pepeiborra@gmail.com\nhomepage: http://pepeiborra.github.com/control-monad-exception\nsynopsis: MTL instances f"-         (Fingerprint 18274748422558568404 4043538769550834851)-         (Fingerprint 11395257416101232635 4303318131190196308)-         (bsReplace " default- extensions:" "unknown-section")-    -- http://hackage.haskell.org/package/vacuum-opengl-0.0-    -- \DEL character-    , mk "Name:                vacuum-opengl\nVersion:             0.0\nSynopsis:            Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription:         \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n     "-         (Fingerprint 5946760521961682577 16933361639326309422)-         (Fingerprint 14034745101467101555 14024175957788447824)-         (bsRemove "\DEL")-    , mk "Name:                vacuum-opengl\nVersion:             0.0.1\nSynopsis:            Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription:         \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n   "-         (Fingerprint 10790950110330119503 1309560249972452700)-         (Fingerprint 1565743557025952928 13645502325715033593)-         (bsRemove "\DEL")-    -- http://hackage.haskell.org/package/ixset-1.0.4-    -- {- comments -}-    , mk "Name:                ixset\nVersion:             1.0.4\nSynopsis:            Efficient relational queries on Haskell sets.\nDescription:\n    Create and query sets that are indexed by multiple indices.\nLicense:             BSD3\nLicense-file:        COPYING\nAut"-         (Fingerprint 11886092342440414185 4150518943472101551)-         (Fingerprint 5731367240051983879 17473925006273577821)-         (bsRemoveStarting "{-")-    -- : after section-    -- http://hackage.haskell.org/package/ds-kanren-    , mk "name:                ds-kanren\nversion:             0.2.0.0\nsynopsis:            A subset of the miniKanren language\ndescription:\n  ds-kanren is an implementation of the <http://minikanren.org miniKanren> language.\n  .\n  == What's in ds-kanren?\n  .\n  ['dis"-         (Fingerprint 2804006762382336875 9677726932108735838)-         (Fingerprint 9830506174094917897 12812107316777006473)-         (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"")-    , mk "name:                ds-kanren\nversion:             0.2.0.1\nsynopsis:            A subset of the miniKanren language\ndescription:\n  ds-kanren is an implementation of the <http://minikanren.org miniKanren> language.\n\nlicense:             MIT\nlicense-file:  "-         (Fingerprint 9130259649220396193 2155671144384738932)-         (Fingerprint 1847988234352024240 4597789823227580457)-         (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"")-    , mk "name:                metric\nversion:             0.1.4\nsynopsis:            Metric spaces.\nlicense:             MIT\nlicense-file:        LICENSE\nauthor:              Vikram Verma\nmaintainer:          me@vikramverma.com\ncategory:            Data\nbuild-type:"-         (Fingerprint 6150019278861565482 3066802658031228162)-         (Fingerprint 9124826020564520548 15629704249829132420)-         (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"")-    , mk "name:                metric\nversion:             0.2.0\nsynopsis:            Metric spaces.\nlicense:             MIT\nlicense-file:        LICENSE\nauthor:              Vikram Verma\nmaintainer:          me@vikramverma.com\ncategory:            Data\nbuild-type:"-         (Fingerprint 4639805967994715694 7859317050376284551)-         (Fingerprint 5566222290622325231 873197212916959151)-         (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"")-    , mk "name:          phasechange\ncategory:      Data\nversion:       0.1\nauthor:        G\195\161bor Lehel\nmaintainer:    G\195\161bor Lehel <illissius@gmail.com>\nhomepage:      http://github.com/glehel/phasechange\ncopyright:     Copyright (C) 2012 G\195\161bor Lehel\nlicense:     "-         (Fingerprint 10546509771395401582 245508422312751943)-         (Fingerprint 5169853482576003304 7247091607933993833)-         (bsReplace "impl(ghc >= 7.4):" "erroneous-section" . bsReplace "impl(ghc >= 7.6):" "erroneous-section")-    , mk "Name:                smartword\nSynopsis:            Web based flash card for Word Smart I and II vocabularies\nVersion:             0.0.0.5\nHomepage:            http://kyagrd.dyndns.org/~kyagrd/project/smartword/\nCategory:            Web,Education\nLicense: "-         (Fingerprint 7803544783533485151 10807347873998191750)-         (Fingerprint 1665635316718752601 16212378357991151549)-         (bsReplace "build depends:" "--")-    , mk "name:           shelltestrunner\n-- sync with README.md, ANNOUNCE:\nversion:        1.3\ncategory:       Testing\nsynopsis:       A tool for testing command-line programs.\ndescription:\n shelltestrunner is a cross-platform tool for testing command-line\n program"-         (Fingerprint 4403237110790078829 15392625961066653722)-         (Fingerprint 10218887328390239431 4644205837817510221)-         (bsReplace "other modules:" "--")-    -- &&!-    -- http://hackage.haskell.org/package/hblas-0.3.0.0-    , mk "-- Initial hblas.cabal generated by cabal init.  For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname:                hblas\n\n-- The package version.  See the Haskell package versioning policy (PVP) \n-- "-         (Fingerprint 8570120150072467041 18315524331351505945)-         (Fingerprint 10838007242302656005 16026440017674974175)-         (bsReplace "&&!" "&& !")-    , mk "-- Initial hblas.cabal generated by cabal init.  For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname:                hblas\n\n-- The package version.  See the Haskell package versioning policy (PVP) \n-- "-         (Fingerprint 5262875856214215155 10846626274067555320)-         (Fingerprint 3022954285783401045 13395975869915955260)-         (bsReplace "&&!" "&& !")-    , mk "-- Initial hblas.cabal generated by cabal init.  For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname:                hblas\n\n-- The package version.  See the Haskell package versioning policy (PVP) \n-- "-         (Fingerprint 54222628930951453 5526514916844166577)-         (Fingerprint 1749630806887010665 8607076506606977549)-         (bsReplace "&&!" "&& !")-    , mk "-- Initial hblas.cabal generated by cabal init.  For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname:                hblas\n\n-- The package version.  See the Haskell package versioning policy (PVP)\n-- fo"-         (Fingerprint 6817250511240350300 15278852712000783849)-         (Fingerprint 15757717081429529536 15542551865099640223)-         (bsReplace "&&!" "&& !")-    , mk "-- Initial hblas.cabal generated by cabal init.  For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname:                hblas\n\n-- The package version.  See the Haskell package versioning policy (PVP)\n-- fo"-         (Fingerprint 8310050400349211976 201317952074418615)-         (Fingerprint 10283381191257209624 4231947623042413334)-         (bsReplace "&&!" "&& !")-    , mk "-- Initial hblas.cabal generated by cabal init.  For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname:                hblas\n\n-- The package version.  See the Haskell package versioning policy (PVP)\n-- fo"-         (Fingerprint 7010988292906098371 11591884496857936132)-         (Fingerprint 6158672440010710301 6419743768695725095)-         (bsReplace "&&!" "&& !")-    , mk "-- Initial hblas.cabal generated by cabal init.  For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname:                hblas\r\n\r\n-- The package version.  See the Haskell package versioning policy (PVP)"-         (Fingerprint 2076850805659055833 16615160726215879467)-         (Fingerprint 10634706281258477722 5285812379517916984)-         (bsReplace "&&!" "&& !")-    , mk "-- Initial hblas.cabal generated by cabal init.  For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname:                hblas\r\n\r\n-- The package version.  See the Haskell package versioning policy (PVP)"-         (Fingerprint 11850020631622781099 11956481969231030830)-         (Fingerprint 13702868780337762025 13383526367149067158)-         (bsReplace "&&!" "&& !")-    , mk "-- Initial hblas.cabal generated by cabal init.  For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname:                hblas\n\n-- The package version.  See the Haskell package versioning policy (PVP)\n-- fo"-         (Fingerprint 13690322768477779172 19704059263540994)-         (Fingerprint 11189374824645442376 8363528115442591078)-         (bsReplace "&&!" "&& !")-    -- flag used, but not defined-    , mk "name:                brainheck\nversion:             0.1.0.2\nsynopsis:            Brainh*ck interpreter in haskell\ndescription:         Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\nhomepage:            https://gi"-         (Fingerprint 6910727116443152200 15401634478524888973)-         (Fingerprint 16551412117098094368 16260377389127603629)-         (bsReplace "flag(llvm-fast)" "False")-    , mk "name:                brainheck\r\nversion:             0.1.0.2\r\nx-revision: 1\r\nsynopsis:            Brainh*ck interpreter in haskell\r\ndescription:         Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage:   "-         (Fingerprint 14320987921316832277 10031098243571536929)-         (Fingerprint 7959395602414037224 13279941216182213050)-         (bsReplace "flag(llvm-fast)" "False")-    , mk "name:                brainheck\r\nversion:             0.1.0.2\r\nx-revision: 2\r\nsynopsis:            Brainh*ck interpreter in haskell\r\ndescription:         Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage:   "-         (Fingerprint 3809078390223299128 10796026010775813741)-         (Fingerprint 1127231189459220796 12088367524333209349)-         (bsReplace "flag(llvm-fast)" "False")-    , mk "name:                brainheck\r\nversion:             0.1.0.2\r\nx-revision: 3\r\nsynopsis:            Brainh*ck interpreter in haskell\r\ndescription:         Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage:   "-         (Fingerprint 13860013038089410950 12479824176801390651)-         (Fingerprint 4687484721703340391 8013395164515771785)-         (bsReplace "flag(llvm-fast)" "False")-    , mk "name:                wordchoice\nversion:             0.1.0.1\nsynopsis:            Get word counts and distributions\ndescription:         A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho"-         (Fingerprint 16215911397419608203 15594928482155652475)-         (Fingerprint 15120681510314491047 2666192399775157359)-         (bsReplace "flag(llvm-fast)" "False")-    , mk "name:                wordchoice\r\nversion:             0.1.0.1\r\nx-revision: 1\r\nsynopsis:            Get word counts and distributions\r\ndescription:         A command line tool to compute the word distribution from various types of document, converting to te"-         (Fingerprint 16593139224723441188 4052919014346212001)-         (Fingerprint 3577381082410411593 11481899387780544641)-         (bsReplace "flag(llvm-fast)" "False")-    , mk "name:                wordchoice\nversion:             0.1.0.2\nsynopsis:            Get word counts and distributions\ndescription:         A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho"-         (Fingerprint 9321301260802539374 1316392715016096607)-         (Fingerprint 3784628652257760949 12662640594755291035)-         (bsReplace "flag(llvm-fast)" "False")-    , mk "name:                wordchoice\r\nversion:             0.1.0.2\r\nx-revision: 1\r\nsynopsis:            Get word counts and distributions\r\ndescription:         A command line tool to compute the word distribution from various types of document, converting to te"-         (Fingerprint 2546901804824433337 2059732715322561176)-         (Fingerprint 8082068680348326500 615008613291421947)-         (bsReplace "flag(llvm-fast)" "False")-    , mk "name:                wordchoice\nversion:             0.1.0.3\nsynopsis:            Get word counts and distributions\ndescription:         A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho"-         (Fingerprint 2282380737467965407 12457554753171662424)-         (Fingerprint 17324757216926991616 17172911843227482125)-         (bsReplace "flag(llvm-fast)" "False")-    , mk "name:                wordchoice\r\nversion:             0.1.0.3\r\nx-revision: 1\r\nsynopsis:            Get word counts and distributions\r\ndescription:         A command line tool to compute the word distribution from various types of document, converting to te"-         (Fingerprint 12907988890480595481 11078473638628359710)-         (Fingerprint 13246185333368731848 4663060731847518614)-         (bsReplace "flag(llvm-fast)" "False")-    , mk "name:                hw-prim-bits\nversion:             0.1.0.0\nsynopsis:            Primitive support for bit manipulation\ndescription:         Please see README.md\nhomepage:            https://github.com/githubuser/hw-prim-bits#readme\nlicense:            "-         (Fingerprint 12386777729082870356 17414156731912743711)-         (Fingerprint 3452290353395041602 14102887112483033720)-         (bsReplace "flag(sse42)" "False")-    , mk "name:                   hw-prim-bits\nversion:                0.1.0.1\nsynopsis:               Primitive support for bit manipulation\ndescription:            Please see README.md\nhomepage:               https://github.com/githubuser/hw-prim-bits#readme\nlicen"-         (Fingerprint 6870520675313101180 14553457351296240636)-         (Fingerprint 12481021059537696455 14711088786769892762)-         (bsReplace "flag(sse42)" "False")-    -- leading zeros in version digits-    -- https://github.com/haskell-infra/hackage-trustees/issues/128-    -- https://github.com/haskell/cabal/issues/5092-    -- https://github.com/haskell/cabal/issues/5138-    , mk "name:            Sit\nversion:         0.2017.02.26\nbuild-type:      Simple\ncabal-version:   >= 1.8\nlicense:         OtherLicense\nlicense-file:    LICENSE\nauthor:          Anonymous\nmaintainer:      Anonymous\nhomepage:        NONE\ncategory:        Dependent"-         (Fingerprint 8458530898096910998 3228538743646501413)-         (Fingerprint 14470502514907936793 17514354054641875371)-         (bsReplace "0.2017.02.26" "0.2017.2.26")-    , mk "name:            Sit\nversion:         0.2017.05.01\nbuild-type:      Simple\ncabal-version:   >= 1.8\nlicense:         OtherLicense\nlicense-file:    LICENSE\nauthor:          Andreas Abel <andreas.abel@gu.se>\nmaintainer:      Andreas Abel <andreas.abel@gu.se>\n"-         (Fingerprint 1450130849535097473 11742099607098860444)-         (Fingerprint 16679762943850814021 4253724355613883542)-         (bsReplace "0.2017.05.01" "0.2017.5.1")-    , mk "name:            Sit\nversion:         0.2017.05.02\nbuild-type:      Simple\ncabal-version:   >= 1.8\nlicense:         OtherLicense\nlicense-file:    LICENSE\nauthor:          Andreas Abel <andreas.abel@gu.se>\nmaintainer:      Andreas Abel <andreas.abel@gu.se>\n"-         (Fingerprint 297248532398492441 17322625167861324800)-         (Fingerprint 634812045126693280 1755581866539318862)-         (bsReplace "0.2017.05.02" "0.2017.5.2")-    , mk "name:            Sit\nversion:         0.2017.5.02\nx-revision: 1\n-- x-revision:1 see https://github.com/haskell-infra/hackage-trustees/issues/128\nbuild-type:      Simple\ncabal-version:   >= 1.8\nlicense:         OtherLicense\nlicense-file:    LICENSE\nauthor: "-         (Fingerprint 3697869560530373941 3942982281026987312)-         (Fingerprint 14344526114710295386 16386400353475114712)-         (bsReplace "0.2017.5.02" "0.2017.5.2")-    , mk "name:            MiniAgda\nversion:         0.2017.02.18\nbuild-type:      Simple\ncabal-version:   >= 1.22\nlicense:         OtherLicense\nlicense-file:    LICENSE\nauthor:          Andreas Abel and Karl Mehltretter\nmaintainer:      Andreas Abel <andreas.abel@i"-         (Fingerprint 17167128953451088679 4300350537748753465)-         (Fingerprint 12402236925293025673 7715084875284020606)-         (bsReplace "0.2017.02.18" "0.2017.2.18")-    , mk "cabal-version:\n  2.0\nname:\n  fast-downward\nversion:\n  0.1.0.0\nbuild-type:\n  Simple\nsynopsis:\n  Solve classical planning problems (STRIPS/SAS+) using Haskell & Fast Downward.\ndescription:\n  @fast-downward@ is a library for modelling classical planning probl"-         (Fingerprint 11256076039027887363 6867903407496243216)-         (Fingerprint 12159816716813155434 5278015399212299853)-         (bsReplace "1.2.03.0" "1.2.3.0")-    , mk "cabal-version:\r\n  2.0\r\nname:\r\n  fast-downward\r\nversion:\r\n  0.1.0.0\r\nx-revision: \r\n  1\r\nbuild-type:\r\n  Simple\r\nsynopsis:\r\n  Solve classical planning problems (STRIPS/SAS+) using Haskell & Fast Downward.\r\ndescription:\r\n  @fast-downward@ is a library for mode"-         (Fingerprint 9216193973149680231 893446343655828508)-         (Fingerprint 10020169545407746427 1828336750379510675)-         (bsReplace "1.2.03.0" "1.2.3.0")-    , mk "cabal-version:\n  2.0\nname:\n  fast-downward\nversion:\n  0.1.0.1\nbuild-type:\n  Simple\nsynopsis:\n  Solve classical planning problems (STRIPS/SAS+) using Haskell & Fast Downward.\ndescription:\n  @fast-downward@ is a library for modelling classical planning probl"-         (Fingerprint 9899886602574848632 5980433644983783334)-         (Fingerprint 12007469255857289958 8321466548645225439)-         (bsReplace "1.2.03.0" "1.2.3.0")-    , mk "cabal-version:\n  2.0\nname:\n  fast-downward\nversion:\n  0.1.1.0\nbuild-type:\n  Simple\nsynopsis:\n  Solve classical planning problems (STRIPS/SAS+) using Haskell & Fast Downward.\ndescription:\n  @fast-downward@ is a library for modelling classical planning probl"-         (Fingerprint 12694656661460787751 1902242956706735615)-         (Fingerprint 15433152131513403849 2284712791516353264)-         (bsReplace "1.2.03.0" "1.2.3.0")-    -- 9 digits limit-    , mk "Name:                SGplus\nVersion:             1.1\nSynopsis:            (updated) Small geometry library for dealing with vectors and collision detection\nLicense:             BSD3\nLicense-file:        LICENSE\nAuthor:              Neil Brown\nMaintainer:  "-         (Fingerprint 17735649550442248029 11493772714725351354)-         (Fingerprint 9565458801063261772 15955773698774721052)-         (bsReplace "1000000000" "100000000")-    , mk "-- Initial control-dotdotdot.cabal generated by cabal init.  For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\nname:                control-dotdotdot\nversion:             0.1.0.1\nsynopsis:            Haskell operator\n               "-         (Fingerprint 1514257173776509942 7756050823377346485)-         (Fingerprint 14082092642045505999 18415918653404121035)-         (bsReplace "9223372036854775807" "5")-    , mk "name:                data-foldapp\r\nversion:             0.1.1.0\r\nsynopsis:            Fold function applications. Framework for variadic functions.\r\ndescription:         Fold function applications. Framework for variadic functions.\r\nhomepage:            ht"-         (Fingerprint 4511234156311243251 11701153011544112556)-         (Fingerprint 11820542702491924189 4902231447612406724)-         (bsReplace "9223372036854775807" "999" . bsReplace "9223372036854775807" "999")-    , mk "-- Initial data-list-zigzag.cabal generated by cabal init.  For further \r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\nname:                data-list-zigzag\r\nversion:             0.1.1.1\r\nsynopsis:            A list but with a balanced en"-         (Fingerprint 12475837388692175691 18053834261188158945)-         (Fingerprint 16279938253437334942 15753349540193002309)-         (bsReplace "9223372036854775807" "999")-    -- Not UTF8-    , mk "Name:                     nat\nVersion:                  0.1\nDescription:            Implementation of natural numbers and integers by a binary\n                                representation. The implementation is supposed to be lazy and\n                   "-         (Fingerprint 9222512268705577108 13085311382746579495)-         (Fingerprint 17468921266614378430 13221316288008291892)-         (bsReplace "\xf6" "\xc3\xb6")-    -- cabal-version: 2-    , mk "name:                streaming-bracketed\nversion:             0.1.0.0\nsynopsis:            A resource management decorator for \"streaming\".        \ndescription:         This package provides a decorator for the Stream type from\n                     the \"st"-         (Fingerprint 14670044663153191927 1427497586294143829)-         (Fingerprint 9233007756654759985 6571998449003682006)-         (bsReplace "cabal-version:       2" "cabal-version: 2.0")-    , mk "name:                streaming-bracketed\nversion:             0.1.0.1\nsynopsis:            A resource management decorator for \"streaming\".        \ndescription:         This package provides a decorator for the Stream type from\n                     \"stream"-         (Fingerprint 7298738862909203815 10141693276062967842)-         (Fingerprint 1349949738792220441 3593683359695349293)-         (bsReplace "cabal-version:       2" "cabal-version: 2.0")-    , mk "name:           zsyntax\nversion:        0.2.0.0\ndescription:    An automated theorem prover for Zsyntax, a\n                logical calculus for molecular biology inspired by linear logic,\n                that can be used to automatically verify biological\n"-         (Fingerprint 17812331267506881875 3005293725141563863)-         (Fingerprint 3445957263137759540 12472369104312474458)-         (bsReplace "cabal-version:  2" "cabal-version: 2.0")--    -- Empty filepath in not license-file or data-dir-    -- These have hs-source-dirs: ""-    , mk "\nname:                wai-middleware-hmac-client\nversion:             0.1.0.1\nlicense:             BSD3\nlicense-file:        LICENSE\nauthor:              Christopher Reichert\nmaintainer:          creichert07@gmail.com\ncopyright:           (c) 2015, Christo"-         (Fingerprint 3112606538775065787 11984607507024462091)-         (Fingerprint 6916432989977230500 6621389616675138128)-         (bsReplace "\"\"" ".")-    , mk "\nname:                wai-middleware-hmac-client\nversion:             0.1.0.2\nlicense:             BSD3\nlicense-file:        LICENSE\nauthor:              Christopher Reichert\nmaintainer:          creichert07@gmail.com\ncopyright:           (c) 2015, Christo"-         (Fingerprint 12566783342663020458 17562089389615949789)-         (Fingerprint 15745683452603944938 10556498036622072844)-         (bsReplace "\"\"" ".")--    -- absolute license-file-    , mk "name: reheat\nversion: 0.1.4\ncabal-version: >=1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner <palipalo9@gmail.com>\nstability: experimental\nhomepage: h"-         (Fingerprint 9155400339287317061 14812953666990892802)-         (Fingerprint 7687053346032173923 15384472501136606592)-         (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "")-    , mk "name: reheat\nversion: 0.1.5\ncabal-version: >=1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner <palipalo9@gmail.com>\nstability: experimental\nhomepage: h"-         (Fingerprint 2984391146441073709 11728234882049907993)-         (Fingerprint 12058479081855347701 14017937756688869826)-         (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "")-    ]-  where-    mk a b c d = ((a, b), (c, d))---- | Helper to create entries in patches-_makePatchKey :: FilePath -> (BS.ByteString -> BS.ByteString) -> IO ()-_makePatchKey fp transform = do-    contents <- BS.readFile fp-    let output = transform contents-    let Fingerprint hi lo = md5 contents-    let Fingerprint hi' lo' = md5 output-    putStrLn-        $ showString "    , mk "-        . shows (BS.take 256 contents)-        . showString "\n         (Fingerprint "-        . shows hi-        . showString " "-        . shows lo-        . showString ")\n         (Fingerprint "-        . shows hi'-        . showString " "-        . shows lo'-        . showString ")"-        $ ""------------------------------------------------------------------------------------ Patch helpers----------------------------------------------------------------------------------bsRemove-    :: BS.ByteString  -- ^ needle-    -> BS.ByteString -> BS.ByteString-bsRemove needle haystack = case BS.breakSubstring needle haystack of-    (h, t) -> BS.append h (BS.drop (BS.length needle) t)--bsReplace-    :: BS.ByteString -- ^ needle-    -> BS.ByteString -- ^ replacement-    -> BS.ByteString -> BS.ByteString-bsReplace needle repl haystack = case BS.breakSubstring needle haystack of-    (h, t)-        | not (BS.null t) -> BS.append h (BS.append repl (BS.drop (BS.length needle) t))-        | otherwise -> haystack--bsRemoveStarting-    :: BS.ByteString  -- ^ needle-    -> BS.ByteString -> BS.ByteString-bsRemoveStarting needle haystack = case BS.breakSubstring needle haystack of-    (h, _) -> h
− src/Distribution/PackageDescription/Utils.hs 
@@ -1,23 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription.Utils------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Common utils used by modules under Distribution.PackageDescription.*.--module Distribution.PackageDescription.Utils (-  cabalBug, userBug-  ) where---- ------------------------------------------------------------------------------- Exception and logging utils--userBug :: String -> a-userBug msg = error $ msg ++ ". This is a bug in your .cabal file."--cabalBug :: String -> a-cabalBug msg = error $ msg ++ ". This is possibly a bug in Cabal.\n"-               ++ "Please report it to the developers: "-               ++ "https://github.com/haskell/cabal/issues/new"
− src/Distribution/Parsec.hs 
@@ -1,524 +0,0 @@-{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Parsec (-    Parsec(..),-    ParsecParser (..),-    runParsecParser,-    runParsecParser',-    simpleParsec,-    simpleParsecBS,-    simpleParsec',-    simpleParsecW',-    lexemeParsec,-    eitherParsec,-    explicitEitherParsec,-    explicitEitherParsec',-    -- * CabalParsing and diagnostics-    CabalParsing (..),-    -- ** Warnings-    PWarnType (..),-    PWarning (..),-    showPWarning,-    -- ** Errors-    PError (..),-    showPError,-    -- * Position-    Position (..),-    incPos,-    retPos,-    showPos,-    zeroPos,-    -- * Utilities-    parsecToken,-    parsecToken',-    parsecFilePath,-    parsecQuoted,-    parsecMaybeQuoted,-    parsecCommaList,-    parsecCommaNonEmpty,-    parsecLeadingCommaList,-    parsecLeadingCommaNonEmpty,-    parsecOptCommaList,-    parsecLeadingOptCommaList,-    parsecStandard,-    parsecUnqualComponentName,-    ) where--import Data.ByteString                     (ByteString)-import Data.Char                           (digitToInt, intToDigit)-import Data.List                           (transpose)-import Distribution.CabalSpecVersion-import Distribution.Compat.Prelude-import Distribution.Parsec.Error           (PError (..), showPError)-import Distribution.Parsec.FieldLineStream (FieldLineStream, fieldLineStreamFromBS, fieldLineStreamFromString)-import Distribution.Parsec.Position        (Position (..), incPos, retPos, showPos, zeroPos)-import Distribution.Parsec.Warning         (PWarnType (..), PWarning (..), showPWarning)-import Numeric                             (showIntAtBase)-import Prelude ()--import qualified Distribution.Compat.CharParsing as P-import qualified Distribution.Compat.DList       as DList-import qualified Distribution.Compat.MonadFail   as Fail-import qualified Text.Parsec                     as Parsec------------------------------------------------------------------------------------ Class------------------------------------------------------------------------------------ | Class for parsing with @parsec@. Mainly used for @.cabal@ file fields.------ For parsing @.cabal@ like file structure, see "Distribution.Fields".----class Parsec a where-    parsec :: CabalParsing m => m a---- | Parsing class which------ * can report Cabal parser warnings.------ * knows @cabal-version@ we work with----class (P.CharParsing m, MonadPlus m, Fail.MonadFail m) => CabalParsing m where-    parsecWarning :: PWarnType -> String -> m ()--    parsecHaskellString :: m String-    parsecHaskellString = stringLiteral--    askCabalSpecVersion :: m CabalSpecVersion---- | 'parsec' /could/ consume trailing spaces, this function /will/ consume.-lexemeParsec :: (CabalParsing m, Parsec a) => m a-lexemeParsec = parsec <* P.spaces--newtype ParsecParser a = PP { unPP-    :: CabalSpecVersion -> Parsec.Parsec FieldLineStream [PWarning] a-    }--liftParsec :: Parsec.Parsec FieldLineStream [PWarning] a -> ParsecParser a-liftParsec p = PP $ \_ -> p--instance Functor ParsecParser where-    fmap f p = PP $ \v -> fmap f (unPP p v)-    {-# INLINE fmap #-}--    x <$ p = PP $ \v -> x <$ unPP p v-    {-# INLINE (<$) #-}--instance Applicative ParsecParser where-    pure = liftParsec . pure-    {-# INLINE pure #-}--    f <*> x = PP $ \v -> unPP f v <*> unPP x v-    {-# INLINE (<*>) #-}-    f  *> x = PP $ \v -> unPP f v  *> unPP x v-    {-# INLINE (*>) #-}-    f <*  x = PP $ \v -> unPP f v <*  unPP x v-    {-# INLINE (<*) #-}--instance Alternative ParsecParser where-    empty = liftParsec empty--    a <|> b = PP $ \v -> unPP a v <|> unPP b v-    {-# INLINE (<|>) #-}--    many p = PP $ \v -> many (unPP p v)-    {-# INLINE many #-}--    some p = PP $ \v -> some (unPP p v)-    {-# INLINE some #-}--instance Monad ParsecParser where-    return = pure--    m >>= k = PP $ \v -> unPP m v >>= \x -> unPP (k x) v-    {-# INLINE (>>=) #-}-    (>>) = (*>)-    {-# INLINE (>>) #-}--#if !(MIN_VERSION_base(4,13,0))-    fail = Fail.fail-#endif--instance MonadPlus ParsecParser where-    mzero = empty-    mplus = (<|>)--instance Fail.MonadFail ParsecParser where-    fail = P.unexpected--instance P.Parsing ParsecParser where-    try p           = PP $ \v -> P.try (unPP p v)-    p <?> d         = PP $ \v -> unPP p v P.<?> d-    skipMany p      = PP $ \v -> P.skipMany (unPP p v)-    skipSome p      = PP $ \v -> P.skipSome (unPP p v)-    unexpected      = liftParsec . P.unexpected-    eof             = liftParsec P.eof-    notFollowedBy p = PP $ \v -> P.notFollowedBy (unPP p v)--instance P.CharParsing ParsecParser where-    satisfy   = liftParsec . P.satisfy-    char      = liftParsec . P.char-    notChar   = liftParsec . P.notChar-    anyChar   = liftParsec P.anyChar-    string    = liftParsec . P.string--instance CabalParsing ParsecParser where-    parsecWarning t w = liftParsec $ do-        spos <- Parsec.getPosition-        Parsec.modifyState-            (PWarning t (Position (Parsec.sourceLine spos) (Parsec.sourceColumn spos)) w :)-    askCabalSpecVersion = PP pure---- | Parse a 'String' with 'lexemeParsec'.-simpleParsec :: Parsec a => String -> Maybe a-simpleParsec-    = either (const Nothing) Just-    . runParsecParser lexemeParsec "<simpleParsec>"-    . fieldLineStreamFromString---- | Like 'simpleParsec' but for 'ByteString'-simpleParsecBS :: Parsec a => ByteString -> Maybe a-simpleParsecBS-    = either (const Nothing) Just-    . runParsecParser lexemeParsec "<simpleParsec>"-    . fieldLineStreamFromBS---- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'.------ @since 3.4.0.0-simpleParsec' :: Parsec a => CabalSpecVersion -> String -> Maybe a-simpleParsec' spec-    = either (const Nothing) Just-    . runParsecParser' spec lexemeParsec "<simpleParsec>"-    . fieldLineStreamFromString---- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'.--- Fail if there are any warnings.------ @since 3.4.0.0-simpleParsecW' :: Parsec a => CabalSpecVersion -> String -> Maybe a-simpleParsecW' spec-    = either (const Nothing) (\(x, ws) -> if null ws then Just x else Nothing)-    . runParsecParser' spec ((,) <$> lexemeParsec <*> liftParsec Parsec.getState) "<simpleParsec>"-    . fieldLineStreamFromString---- | Parse a 'String' with 'lexemeParsec'.-eitherParsec :: Parsec a => String -> Either String a-eitherParsec = explicitEitherParsec parsec---- | Parse a 'String' with given 'ParsecParser'. Trailing whitespace is accepted.-explicitEitherParsec :: ParsecParser a -> String -> Either String a-explicitEitherParsec parser-    = either (Left . show) Right-    . runParsecParser (parser <* P.spaces) "<eitherParsec>"-    . fieldLineStreamFromString---- | Parse a 'String' with given 'ParsecParser' and 'CabalSpecVersion'. Trailing whitespace is accepted.--- See 'explicitEitherParsec'.------ @since 3.4.0.0----explicitEitherParsec' :: CabalSpecVersion -> ParsecParser a -> String -> Either String a-explicitEitherParsec' spec parser-    = either (Left . show) Right-    . runParsecParser' spec (parser <* P.spaces) "<eitherParsec>"-    . fieldLineStreamFromString---- | Run 'ParsecParser' with 'cabalSpecLatest'.-runParsecParser :: ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a-runParsecParser = runParsecParser' cabalSpecLatest---- | Like 'runParsecParser' but lets specify 'CabalSpecVersion' used.------ @since 3.0.0.0----runParsecParser' :: CabalSpecVersion -> ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a-runParsecParser' v p n = Parsec.runParser (unPP p v <* P.eof) [] n--instance Parsec a => Parsec (Identity a) where-    parsec = Identity <$> parsec--instance Parsec Bool where-    parsec = P.munch1 isAlpha >>= postprocess-      where-        postprocess str-            |  str == "True"  = pure True-            |  str == "False" = pure False-            | lstr == "true"  = parsecWarning PWTBoolCase caseWarning *> pure True-            | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False-            | otherwise       = fail $ "Not a boolean: " ++ str-          where-            lstr = map toLower str-            caseWarning =-                "Boolean values are case sensitive, use 'True' or 'False'."---- | @[^ ,]@-parsecToken :: CabalParsing m => m String-parsecToken = parsecHaskellString <|> ((P.munch1 (\x -> not (isSpace x) && x /= ',')  P.<?> "identifier" ) >>= checkNotDoubleDash)---- | @[^ ]@-parsecToken' :: CabalParsing m => m String-parsecToken' = parsecHaskellString <|> ((P.munch1 (not . isSpace) P.<?> "token") >>= checkNotDoubleDash)--checkNotDoubleDash ::  CabalParsing m => String -> m String-checkNotDoubleDash s = do-    when (s == "--") $ parsecWarning PWTDoubleDash $ unwords-        [ "Double-dash token found."-        , "Note: there are no end-of-line comments in .cabal files, only whole line comments."-        , "Use \"--\" (quoted double dash) to silence this warning, if you actually want -- token"-        ]--    return s--parsecFilePath :: CabalParsing m => m FilePath-parsecFilePath = parsecToken---- | Parse a benchmark/test-suite types.-parsecStandard :: (CabalParsing m, Parsec ver) => (ver -> String -> a) -> m a-parsecStandard f = do-    cs   <- some $ P.try (component <* P.char '-')-    ver  <- parsec-    let name = map toLower (intercalate "-" cs)-    return $! f ver name-  where-    component = do-      cs <- P.munch1 isAlphaNum-      if all isDigit cs then fail "all digit component" else return cs-      -- each component must contain an alphabetic character, to avoid-      -- ambiguity in identifiers like foo-1 (the 1 is the version number).--parsecCommaList :: CabalParsing m => m a -> m [a]-parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces P.<?> "comma")--parsecCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a)-parsecCommaNonEmpty p = P.sepByNonEmpty (p <* P.spaces) (P.char ',' *> P.spaces P.<?> "comma")---- | Like 'parsecCommaList' but accept leading or trailing comma.------ @--- p (comma p)*  -- p `sepBy` comma--- (comma p)*    -- leading comma--- (p comma)*    -- trailing comma--- @-parsecLeadingCommaList :: CabalParsing m => m a -> m [a]-parsecLeadingCommaList p = do-    c <- P.optional comma-    case c of-        Nothing -> toList <$> P.sepEndByNonEmpty lp comma <|> pure []-        Just _  -> toList <$> P.sepByNonEmpty lp comma-  where-    lp = p <* P.spaces-    comma = P.char ',' *> P.spaces P.<?> "comma"---- |------ @since 3.4.0.0-parsecLeadingCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a)-parsecLeadingCommaNonEmpty p = do-    c <- P.optional comma-    case c of-        Nothing -> P.sepEndByNonEmpty lp comma-        Just _  -> P.sepByNonEmpty lp comma-  where-    lp = p <* P.spaces-    comma = P.char ',' *> P.spaces P.<?> "comma"--parsecOptCommaList :: CabalParsing m => m a -> m [a]-parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma)-  where-    comma = P.char ',' *> P.spaces---- | Like 'parsecOptCommaList' but------ * require all or none commas--- * accept leading or trailing comma.------ @--- p (comma p)*  -- p `sepBy` comma--- (comma p)*    -- leading comma--- (p comma)*    -- trailing comma--- p*            -- no commas: many p--- @------ @since 3.0.0.0----parsecLeadingOptCommaList :: CabalParsing m => m a -> m [a]-parsecLeadingOptCommaList p = do-    c <- P.optional comma-    case c of-        Nothing -> sepEndBy1Start <|> pure []-        Just _  -> toList <$> P.sepByNonEmpty lp comma-  where-    lp = p <* P.spaces-    comma = P.char ',' *> P.spaces P.<?> "comma"--    sepEndBy1Start = do-        x <- lp-        c <- P.optional comma-        case c of-            Nothing -> (x :) <$> many lp-            Just _  -> (x :) <$> P.sepEndBy lp comma---- | Content isn't unquoted-parsecQuoted :: CabalParsing m => m a -> m a-parsecQuoted = P.between (P.char '"') (P.char '"')---- | @parsecMaybeQuoted p = 'parsecQuoted' p <|> p@.-parsecMaybeQuoted :: CabalParsing m => m a -> m a-parsecMaybeQuoted p = parsecQuoted p <|> p--parsecUnqualComponentName :: forall m. CabalParsing m => m String-parsecUnqualComponentName = state0 DList.empty where-    ---    -- using @kleene@ package we can easily see that-    -- we need only two states to recognize-    -- unqual-component-name-    ---    -- Compare with declarative-    -- 'Distribution.FieldGrammar.Described.reUnqualComponent'.-    ---    -- @-    -- import Kleene-    -- import Kleene.Internal.Pretty-    -- import Algebra.Lattice-    -- import Data.Char-    ---    -- import qualified Data.RangeSet.Map as RSet-    ---    -- main = do-    --     -- this is an approximation, to get an idea.-    --     let component :: RE Char-    --         component = star alphaNum <> alpha <> star alphaNum-    ---    --         alphaNum = alpha \/ num-    --         alpha    = unions $ map char ['a'..'z']-    --         num      = unions $ map char ['0'..'9']-    ---    --         re :: RE Char-    --         re = component <> star (char '-' <> component)-    ---    --     putPretty re-    --     putPretty $ fromTM re-    -- @--    state0 :: DList.DList Char -> m String-    state0 acc = do-        c <- ch -- <|> fail ("Invalid component, after " ++ DList.toList acc)-        case () of-            _ | isDigit c    -> state0 (DList.snoc acc c)-              | isAlphaNum c -> state1 (DList.snoc acc c)-              | c == '-'     -> fail ("Empty component, after " ++ DList.toList acc)-              | otherwise    -> fail ("Internal error, after " ++ DList.toList acc)--    state1 :: DList.DList Char -> m String-    state1 acc = state1' acc `alt` return (DList.toList acc)--    state1' :: DList.DList Char -> m String-    state1' acc = do-        c <- ch-        case () of-            _ | isAlphaNum c -> state1 (DList.snoc acc c)-              | c == '-'     -> state0 (DList.snoc acc c)-              | otherwise    -> fail ("Internal error, after " ++ DList.toList acc)--    ch :: m Char-    !ch = P.satisfy (\c -> isAlphaNum c || c == '-')--    alt :: m String -> m String -> m String-    !alt = (<|>)--stringLiteral :: forall m. P.CharParsing m => m String-stringLiteral = lit where-    lit :: m String-    lit = foldr (maybe id (:)) ""-        <$> P.between (P.char '"') (P.char '"' P.<?> "end of string") (many stringChar)-        P.<?> "string"--    stringChar :: m (Maybe Char)-    stringChar = Just <$> stringLetter-         <|> stringEscape-         P.<?> "string character"--    stringLetter :: m Char-    stringLetter = P.satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))--    stringEscape :: m (Maybe Char)-    stringEscape = P.char '\\' *> esc where-        esc :: m (Maybe Char)-        esc = Nothing <$ escapeGap-            <|> Nothing <$ escapeEmpty-            <|> Just <$> escapeCode--    escapeEmpty, escapeGap :: m Char-    escapeEmpty = P.char '&'-    escapeGap = P.skipSpaces1 *> (P.char '\\' P.<?> "end of string gap")--escapeCode :: forall m. P.CharParsing m => m Char-escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) P.<?> "escape code"-  where-  charControl, charNum :: m Char-  charControl = (\c -> toEnum (fromEnum c - fromEnum '@')) <$> (P.char '^' *> (P.upper <|> P.char '@'))-  charNum = toEnum <$> num-    where-      num :: m Int-      num = bounded 10 maxchar-        <|> (P.char 'o' *> bounded 8 maxchar)-        <|> (P.char 'x' *> bounded 16 maxchar)-      maxchar = fromEnum (maxBound :: Char)--  bounded :: Int -> Int -> m Int-  bounded base bnd = foldl' (\x d -> base * x + digitToInt d) 0-                 <$> bounded' (take base thedigits) (map digitToInt $ showIntAtBase base intToDigit bnd "")-    where-      thedigits :: [m Char]-      thedigits = map P.char ['0'..'9'] ++ map P.oneOf (transpose [['A'..'F'],['a'..'f']])--      toomuch :: m a-      toomuch = P.unexpected "out-of-range numeric escape sequence"--      bounded', bounded'' :: [m Char] -> [Int] -> m [Char]-      bounded' dps@(zero:_) bds = P.skipSome zero *> ([] <$ P.notFollowedBy (P.choice dps) <|> bounded'' dps bds)-                              <|> bounded'' dps bds-      bounded' []           _   = error "bounded called with base 0"-      bounded'' dps []         = [] <$ P.notFollowedBy (P.choice dps) <|> toomuch-      bounded'' dps (bd : bds) = let anyd :: m Char-                                     anyd = P.choice dps--                                     nomore :: m ()-                                     nomore = P.notFollowedBy anyd <|> toomuch--                                     (low, ex, high) = case splitAt bd dps of-                                        (low', ex' : high') -> (low', ex', high')-                                        (_, _)              -> error "escapeCode: Logic error"-                                  in ((:) <$> P.choice low <*> atMost (length bds) anyd) <* nomore-                                     <|> ((:) <$> ex <*> ([] <$ nomore <|> bounded'' dps bds))-                                     <|> if not (null bds)-                                            then (:) <$> P.choice high <*> atMost (length bds - 1) anyd <* nomore-                                            else empty-      atMost n p | n <= 0    = pure []-                 | otherwise = ((:) <$> p <*> atMost (n - 1) p) <|> pure []--  charEsc :: m Char-  charEsc = P.choice $ parseEsc <$> escMap--  parseEsc (c,code) = code <$ P.char c-  escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'"--  charAscii :: m Char-  charAscii = P.choice $ parseAscii <$> asciiMap--  parseAscii (asc,code) = P.try $ code <$ P.string asc-  asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)-  ascii2codes, ascii3codes :: [String]-  ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO"-                , "SI","EM","FS","GS","RS","US","SP"]-  ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK"-                ,"BEL","DLE","DC1","DC2","DC3","DC4","NAK"-                ,"SYN","ETB","CAN","SUB","ESC","DEL"]-  ascii2, ascii3 :: String-  ascii2 = "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP"-  ascii3 = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL"
− src/Distribution/Parsec/Error.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Parsec.Error (-    PError (..),-    showPError,-    ) where--import Distribution.Compat.Prelude-import Distribution.Parsec.Position-import Prelude ()-import System.FilePath              (normalise)---- | Parser error.-data PError = PError Position String-    deriving (Show, Generic)--instance Binary PError-instance NFData PError where rnf = genericRnf--showPError :: FilePath -> PError -> String-showPError fpath (PError pos msg) =-    normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg
− src/Distribution/Parsec/FieldLineStream.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# OPTIONS_GHC -Wall -Werror #-}-module Distribution.Parsec.FieldLineStream (-    FieldLineStream (..),-    fieldLineStreamFromString,-    fieldLineStreamFromBS,-    fieldLineStreamEnd,-    ) where--import Data.Bits-import Data.ByteString             (ByteString)-import Distribution.Compat.Prelude-import Distribution.Utils.Generic  (toUTF8BS)-import Prelude ()--import qualified Data.ByteString as BS-import qualified Text.Parsec     as Parsec---- | This is essentially a lazy bytestring, but chunks are glued with newline @\'\\n\'@.-data FieldLineStream-    = FLSLast !ByteString-    | FLSCons {-# UNPACK #-} !ByteString FieldLineStream-  deriving Show--fieldLineStreamEnd :: FieldLineStream-fieldLineStreamEnd = FLSLast mempty---- | Convert 'String' to 'FieldLineStream'.------ /Note:/ inefficient!-fieldLineStreamFromString :: String -> FieldLineStream-fieldLineStreamFromString = FLSLast . toUTF8BS--fieldLineStreamFromBS :: ByteString -> FieldLineStream-fieldLineStreamFromBS = FLSLast--instance Monad m => Parsec.Stream FieldLineStream m Char where-    uncons (FLSLast bs) = return $ case BS.uncons bs of-        Nothing       -> Nothing-        Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSLast bs'') fieldLineStreamEnd)--    uncons (FLSCons bs s) = return $ case BS.uncons bs of-        -- as lines are glued with '\n', we return '\n' here!-        Nothing -> Just ('\n', s)-        Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSCons bs'' s) s)---- Based on implementation 'decodeStringUtf8'-unconsChar :: forall a. Word8 -> ByteString -> (ByteString -> a) -> a -> (Char, a)-unconsChar c0 bs0 f next-    | c0 <= 0x7F = (chr (fromIntegral c0), f bs0)-    | c0 <= 0xBF = (replacementChar, f bs0)-    | c0 <= 0xDF = twoBytes-    | c0 <= 0xEF = moreBytes 3 0x800     bs0 (fromIntegral $ c0 .&. 0xF)-    | c0 <= 0xF7 = moreBytes 4 0x10000   bs0 (fromIntegral $ c0 .&. 0x7)-    | c0 <= 0xFB = moreBytes 5 0x200000  bs0 (fromIntegral $ c0 .&. 0x3)-    | c0 <= 0xFD = moreBytes 6 0x4000000 bs0 (fromIntegral $ c0 .&. 0x1)-    | otherwise = error $ "not implemented " ++ show c0-  where-    twoBytes = case BS.uncons bs0 of-        Nothing -> (replacementChar, next)-        Just (c1, bs1)-            | c1 .&. 0xC0 == 0x80 ->-                if d >= 0x80-                then  (chr d, f bs1)-                else  (replacementChar, f bs1)-            | otherwise -> (replacementChar, f bs1)-          where-            d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F)--    moreBytes :: Int -> Int -> ByteString -> Int -> (Char, a)-    moreBytes 1 overlong bs' acc-        | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc-            = (chr acc, f bs')-        | otherwise-            = (replacementChar, f bs')--    moreBytes byteCount overlong bs' acc = case BS.uncons bs' of-        Nothing                   -> (replacementChar, f bs')-        Just (cn, bs1)-            | cn .&. 0xC0 == 0x80 -> moreBytes-                (byteCount-1)-                overlong-                bs1-                ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)-            | otherwise           -> (replacementChar, f bs1)--replacementChar :: Char-replacementChar = '\xfffd'
− src/Distribution/Parsec/Position.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Parsec.Position (-    Position (..),-    incPos,-    retPos,-    showPos,-    zeroPos,-    positionCol,-    positionRow,-    ) where--import Distribution.Compat.Prelude-import Prelude ()---- | 1-indexed row and column positions in a file.-data Position = Position-    {-# UNPACK #-}  !Int           -- row-    {-# UNPACK #-}  !Int           -- column-  deriving (Eq, Ord, Show, Generic)--instance Binary Position-instance NFData Position where rnf = genericRnf---- | Shift position by n columns to the right.-incPos :: Int -> Position -> Position-incPos n (Position row col) = Position row (col + n)---- | Shift position to beginning of next row.-retPos :: Position -> Position-retPos (Position row _col) = Position (row + 1) 1--showPos :: Position -> String-showPos (Position row col) = show row ++ ":" ++ show col--zeroPos :: Position-zeroPos = Position 0 0---- | @since 3.0.0.0-positionCol :: Position -> Int-positionCol (Position _ c) = c---- | @since 3.0.0.0-positionRow :: Position -> Int-positionRow (Position r _) = r
− src/Distribution/Parsec/Warning.hs 
@@ -1,61 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Parsec.Warning (-    PWarning (..),-    PWarnType (..),-    showPWarning,-    ) where--import Distribution.Compat.Prelude-import Distribution.Parsec.Position-import Prelude ()-import System.FilePath              (normalise)---- | Type of parser warning. We do classify warnings.------ Different application may decide not to show some, or have fatal behaviour on others-data PWarnType-    = PWTOther                 -- ^ Unclassified warning-    | PWTUTF                   -- ^ Invalid UTF encoding-    | PWTBoolCase              -- ^ @true@ or @false@, not @True@ or @False@-    | PWTVersionTag            -- ^ there are version with tags-    | PWTNewSyntax             -- ^ New syntax used, but no @cabal-version: >= 1.2@ specified-    | PWTOldSyntax             -- ^ Old syntax used, and @cabal-version >= 1.2@ specified-    | PWTDeprecatedField-    | PWTInvalidSubsection-    | PWTUnknownField-    | PWTUnknownSection-    | PWTTrailingFields-    | PWTExtraMainIs           -- ^ extra main-is field-    | PWTExtraTestModule       -- ^ extra test-module field-    | PWTExtraBenchmarkModule  -- ^ extra benchmark-module field-    | PWTLexNBSP-    | PWTLexBOM-    | PWTLexTab-    | PWTQuirkyCabalFile       -- ^ legacy cabal file that we know how to patch-    | PWTDoubleDash            -- ^ Double dash token, most likely it's a mistake - it's not a comment-    | PWTMultipleSingularField -- ^ e.g. name or version should be specified only once.-    | PWTBuildTypeDefault      -- ^ Workaround for derive-package having build-type: Default. See <https://github.com/haskell/cabal/issues/5020>.--    | PWTVersionOperator       -- ^ Version operators used (without cabal-version: 1.8)-    | PWTVersionWildcard       -- ^ Version wildcard used (without cabal-version: 1.6)--    | PWTSpecVersion           -- ^ Warnings about cabal-version format.--    | PWTEmptyFilePath         -- ^ Empty filepath, i.e. literally ""--    | PWTExperimental          -- ^ Experimental feature-    deriving (Eq, Ord, Show, Enum, Bounded, Generic)--instance Binary PWarnType-instance NFData PWarnType where rnf = genericRnf---- | Parser warning.-data PWarning = PWarning !PWarnType !Position String-    deriving (Show, Generic)--instance Binary PWarning-instance NFData PWarning where rnf = genericRnf--showPWarning :: FilePath -> PWarning -> String-showPWarning fpath (PWarning _ pos msg) =-    normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg
− src/Distribution/Pretty.hs 
@@ -1,110 +0,0 @@-module Distribution.Pretty (-    Pretty (..),-    prettyShow,-    defaultStyle,-    flatStyle,-    -- * Utilities-    showFilePath,-    showToken,-    showTokenStr,-    showFreeText,-    showFreeTextV3,-    -- * Deprecated-    Separator,-    ) where--import Distribution.CabalSpecVersion-import Distribution.Compat.Prelude-import Prelude ()--import qualified Text.PrettyPrint as PP--class Pretty a where-    pretty :: a -> PP.Doc--    prettyVersioned :: CabalSpecVersion -> a -> PP.Doc-    prettyVersioned _ = pretty---- | @since 3.4.0.0-instance Pretty PP.Doc where-    pretty = id--instance Pretty Bool where-    pretty = PP.text . show--instance Pretty Int where-    pretty = PP.text . show--instance Pretty a => Pretty (Identity a) where-    pretty = pretty . runIdentity--prettyShow :: Pretty a => a -> String-prettyShow = PP.renderStyle defaultStyle . pretty---- | The default rendering style used in Cabal for console--- output. It has a fixed page width and adds line breaks--- automatically.-defaultStyle :: PP.Style-defaultStyle = PP.Style { PP.mode           = PP.PageMode-                          , PP.lineLength     = 79-                          , PP.ribbonsPerLine = 1.0-                          }---- | A style for rendering all on one line.-flatStyle :: PP.Style-flatStyle = PP.Style { PP.mode = PP.LeftMode-                       , PP.lineLength = err "lineLength"-                       , PP.ribbonsPerLine = err "ribbonsPerLine"-                       }-  where-    err x = error ("flatStyle: tried to access " ++ x ++ " in LeftMode. " ++-                   "This should never happen and indicates a bug in Cabal.")------------------------------------------------------------------------------------ Utilities------------------------------------------------------------------------------------ TODO: remove when ReadP parser is gone.-type Separator = [PP.Doc] -> PP.Doc--showFilePath :: FilePath -> PP.Doc-showFilePath = showToken--showToken :: String -> PP.Doc-showToken = PP.text . showTokenStr--showTokenStr :: String -> String-showTokenStr str-    -- if token looks like a comment (starts with --), print it in quotes-    | "--" `isPrefixOf` str                 = show str-    -- also if token ends with a colon (e.g. executable name), print it in quotes-    | ":" `isSuffixOf` str                  = show str-    | not (any dodgy str) && not (null str) = str-    | otherwise                             = show str-  where-    dodgy c = isSpace c || c == ','----- | Pretty-print free-format text, ensuring that it is vertically aligned,--- and with blank lines replaced by dots for correct re-parsing.-showFreeText :: String -> PP.Doc-showFreeText "" = mempty-showFreeText s  = PP.vcat [ PP.text (if null l then "." else l) | l <- lines_ s ]---- | Pretty-print free-format text.--- Since @cabal-version: 3.0@ we don't replace blank lines with dots.------ @since 3.0.0.0-showFreeTextV3 :: String -> PP.Doc-showFreeTextV3 "" = mempty-showFreeTextV3 s  = PP.vcat [ PP.text l | l <- lines_ s ]---- | 'lines_' breaks a string up into a list of strings at newline--- characters.  The resulting strings do not contain newlines.-lines_                   :: String -> [String]-lines_ [] = [""]-lines_ s  =-    let (l, s') = break (== '\n') s-    in  l : case s' of-        []      -> []-        (_:s'') -> lines_ s''
src/Distribution/ReadE.hs view
@@ -1,4 +1,7 @@+{-# LANGUAGE LambdaCase #-}+ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.ReadE -- Copyright   :  Jose Iborra 2008@@ -8,29 +11,37 @@ -- Portability :  portable -- -- Simple parsing with failure+module Distribution.ReadE+  ( -- * ReadE+    ReadE (..)+  , succeedReadE+  , failReadE -module Distribution.ReadE (-   -- * ReadE-   ReadE(..), succeedReadE, failReadE,-   -- * Projections-   readEOrFail,-   parsecToReadE,+    -- * Projections+  , parsecToReadE+  , parsecToReadEErr++    -- * Parse Errors+  , unexpectMsgString   ) where +import qualified Data.Bifunctor as Bi (first) import Distribution.Compat.Prelude import Prelude ()  import Distribution.Parsec import Distribution.Parsec.FieldLineStream+import qualified Text.Parsec.Error as Parsec  -- | Parser with simple error reporting newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a}-type ErrorMsg   = String +type ErrorMsg = String+ instance Functor ReadE where   fmap f (ReadE p) = ReadE $ \txt -> case p txt of-                                       Right a  -> Right (f a)-                                       Left err -> Left err+    Right a -> Right (f a)+    Left err -> Left err  succeedReadE :: (String -> a) -> ReadE a succeedReadE f = ReadE (Right . f)@@ -38,12 +49,23 @@ failReadE :: ErrorMsg -> ReadE a failReadE = ReadE . const . Left -readEOrFail :: ReadE a -> String -> a-readEOrFail r = either error id . runReadE r+runParsecFromString :: ParsecParser a -> String -> Either Parsec.ParseError a+runParsecFromString p txt =+  runParsecParser p "<parsecToReadE>" (fieldLineStreamFromString txt)  parsecToReadE :: (String -> ErrorMsg) -> ParsecParser a -> ReadE a parsecToReadE err p = ReadE $ \txt ->-    case runParsecParser p "<parsecToReadE>" (fieldLineStreamFromString txt) of-        Right x -> Right x-        Left _e -> Left (err txt)--- TODO: use parsec error to make 'ErrorMsg'.+  const (err txt) `Bi.first` runParsecFromString p txt++parsecToReadEErr :: (Parsec.ParseError -> ErrorMsg) -> ParsecParser a -> ReadE a+parsecToReadEErr err p =+  ReadE $+    Bi.first err . runParsecFromString p++-- Show only unexpected error messages+unexpectMsgString :: Parsec.ParseError -> String+unexpectMsgString =+  unlines+    . map Parsec.messageString+    . filter (\case Parsec.UnExpect _ -> True; _ -> False)+    . Parsec.errorMessages
− src/Distribution/SPDX.hs 
@@ -1,40 +0,0 @@--- | This module implements SPDX specification version 2.1 with a version 3.0 license list.------ Specification is available on <https://spdx.org/specifications>-module Distribution.SPDX (-    -- * License-    License (..),-    -- * License expression-    LicenseExpression (..),-    SimpleLicenseExpression (..),-    simpleLicenseExpression,-    -- * License identifier-    LicenseId (..),-    licenseId,-    licenseName,-    licenseIsOsiApproved,-    mkLicenseId,-    licenseIdList,-    -- * License exception-    LicenseExceptionId (..),-    licenseExceptionId,-    licenseExceptionName,-    mkLicenseExceptionId,-    licenseExceptionIdList,-    -- * License reference-    LicenseRef,-    licenseRef,-    licenseDocumentRef,-    mkLicenseRef,-    mkLicenseRef',-    -- * License list version-    LicenseListVersion (..),-    cabalSpecVersionToSPDXListVersion,-    ) where--import Distribution.SPDX.LicenseExceptionId-import Distribution.SPDX.License-import Distribution.SPDX.LicenseId-import Distribution.SPDX.LicenseExpression-import Distribution.SPDX.LicenseReference-import Distribution.SPDX.LicenseListVersion
− src/Distribution/SPDX/License.hs 
@@ -1,65 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.SPDX.License (-    License (..),-    ) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Pretty-import Distribution.Parsec-import Distribution.SPDX.LicenseExpression--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp---- | Declared license.--- See [section 3.15 of SPDX Specification 2.1](https://spdx.org/spdx-specification-21-web-version#h.1hmsyys)------ /Note:/ the NOASSERTION case is omitted.------ Old 'License' can be migrated using following rules:------ * @AllRightsReserved@ and @UnspecifiedLicense@ to 'NONE'.---   No license specified which legally defaults to /All Rights Reserved/.---   The package may not be legally modified or redistributed by anyone but---   the rightsholder.------ * @OtherLicense@ can be converted to 'LicenseRef' pointing to the file---   in the package.------ * @UnknownLicense@ i.e. other licenses of the form @name-x.y@, should be---   covered by SPDX license list, otherwise use 'LicenseRef'.------ * @PublicDomain@ isn't covered. Consider using CC0.---   See <https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files>---   for more information.----data License-    = NONE-      -- ^ if the package contains no license information whatsoever; or-    | License LicenseExpression-      -- ^ A valid SPDX License Expression as defined in Appendix IV.-  deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)--instance Binary License-instance Structured License--instance NFData License where-    rnf NONE        = ()-    rnf (License l) = rnf l--instance Pretty License where-    pretty NONE        = Disp.text "NONE"-    pretty (License l) = pretty l---- |--- >>> eitherParsec "BSD-3-Clause AND MIT" :: Either String License--- Right (License (EAnd (ELicense (ELicenseId BSD_3_Clause) Nothing) (ELicense (ELicenseId MIT) Nothing)))------ >>> eitherParsec "NONE" :: Either String License--- Right NONE----instance Parsec License where-    parsec = NONE <$ P.try (P.string "NONE") <|> License <$> parsec
− src/Distribution/SPDX/LicenseExceptionId.hs 
@@ -1,316 +0,0 @@--- This file is generated. See Makefile's spdx rule-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.SPDX.LicenseExceptionId (-    LicenseExceptionId (..),-    licenseExceptionId,-    licenseExceptionName,-    mkLicenseExceptionId,-    licenseExceptionIdList,-    ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Compat.Lens (set)-import Distribution.Pretty-import Distribution.Parsec-import Distribution.Utils.Generic (isAsciiAlphaNum)-import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion)-import Distribution.SPDX.LicenseListVersion--import qualified Data.Binary.Get as Binary-import qualified Data.Binary.Put as Binary-import qualified Data.Map.Strict as Map-import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp------------------------------------------------------------------------------------ LicenseExceptionId------------------------------------------------------------------------------------ | SPDX License identifier-data LicenseExceptionId-    = DS389_exception -- ^ @389-exception@, 389 Directory Server Exception-    | Autoconf_exception_2_0 -- ^ @Autoconf-exception-2.0@, Autoconf exception 2.0-    | Autoconf_exception_3_0 -- ^ @Autoconf-exception-3.0@, Autoconf exception 3.0-    | Bison_exception_2_2 -- ^ @Bison-exception-2.2@, Bison exception 2.2-    | Bootloader_exception -- ^ @Bootloader-exception@, Bootloader Distribution Exception-    | Classpath_exception_2_0 -- ^ @Classpath-exception-2.0@, Classpath exception 2.0-    | CLISP_exception_2_0 -- ^ @CLISP-exception-2.0@, CLISP exception 2.0-    | DigiRule_FOSS_exception -- ^ @DigiRule-FOSS-exception@, DigiRule FOSS License Exception-    | ECos_exception_2_0 -- ^ @eCos-exception-2.0@, eCos exception 2.0-    | Fawkes_Runtime_exception -- ^ @Fawkes-Runtime-exception@, Fawkes Runtime Exception-    | FLTK_exception -- ^ @FLTK-exception@, FLTK exception-    | Font_exception_2_0 -- ^ @Font-exception-2.0@, Font exception 2.0-    | Freertos_exception_2_0 -- ^ @freertos-exception-2.0@, FreeRTOS Exception 2.0-    | GCC_exception_2_0 -- ^ @GCC-exception-2.0@, GCC Runtime Library exception 2.0-    | GCC_exception_3_1 -- ^ @GCC-exception-3.1@, GCC Runtime Library exception 3.1-    | Gnu_javamail_exception -- ^ @gnu-javamail-exception@, GNU JavaMail exception-    | GPL_3_0_linking_exception -- ^ @GPL-3.0-linking-exception@, GPL-3.0 Linking Exception, SPDX License List 3.9, SPDX License List 3.10-    | GPL_3_0_linking_source_exception -- ^ @GPL-3.0-linking-source-exception@, GPL-3.0 Linking Exception (with Corresponding Source), SPDX License List 3.9, SPDX License List 3.10-    | GPL_CC_1_0 -- ^ @GPL-CC-1.0@, GPL Cooperation Commitment 1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | I2p_gpl_java_exception -- ^ @i2p-gpl-java-exception@, i2p GPL+Java Exception-    | LGPL_3_0_linking_exception -- ^ @LGPL-3.0-linking-exception@, LGPL-3.0 Linking Exception, SPDX License List 3.9, SPDX License List 3.10-    | Libtool_exception -- ^ @Libtool-exception@, Libtool Exception-    | Linux_syscall_note -- ^ @Linux-syscall-note@, Linux Syscall Note-    | LLVM_exception -- ^ @LLVM-exception@, LLVM Exception, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | LZMA_exception -- ^ @LZMA-exception@, LZMA exception-    | Mif_exception -- ^ @mif-exception@, Macros and Inline Functions Exception-    | Nokia_Qt_exception_1_1 -- ^ @Nokia-Qt-exception-1.1@, Nokia Qt LGPL exception 1.1, SPDX License List 3.0, SPDX License List 3.2-    | OCaml_LGPL_linking_exception -- ^ @OCaml-LGPL-linking-exception@, OCaml LGPL Linking Exception, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | OCCT_exception_1_0 -- ^ @OCCT-exception-1.0@, Open CASCADE Exception 1.0-    | OpenJDK_assembly_exception_1_0 -- ^ @OpenJDK-assembly-exception-1.0@, OpenJDK Assembly exception 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | Openvpn_openssl_exception -- ^ @openvpn-openssl-exception@, OpenVPN OpenSSL Exception-    | PS_or_PDF_font_exception_20170817 -- ^ @PS-or-PDF-font-exception-20170817@, PS/PDF font exception (2017-08-17), SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | Qt_GPL_exception_1_0 -- ^ @Qt-GPL-exception-1.0@, Qt GPL exception 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | Qt_LGPL_exception_1_1 -- ^ @Qt-LGPL-exception-1.1@, Qt LGPL exception 1.1, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | Qwt_exception_1_0 -- ^ @Qwt-exception-1.0@, Qwt exception 1.0-    | SHL_2_0 -- ^ @SHL-2.0@, Solderpad Hardware License v2.0, SPDX License List 3.9, SPDX License List 3.10-    | SHL_2_1 -- ^ @SHL-2.1@, Solderpad Hardware License v2.1, SPDX License List 3.9, SPDX License List 3.10-    | Swift_exception -- ^ @Swift-exception@, Swift Exception, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | U_boot_exception_2_0 -- ^ @u-boot-exception-2.0@, U-Boot exception 2.0-    | Universal_FOSS_exception_1_0 -- ^ @Universal-FOSS-exception-1.0@, Universal FOSS Exception, Version 1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | WxWindows_exception_3_1 -- ^ @WxWindows-exception-3.1@, WxWindows Library Exception 3.1-  deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data, Generic)--instance Binary LicenseExceptionId where-    put = Binary.putWord8 . fromIntegral . fromEnum-    get = do-        i <- Binary.getWord8-        if i > fromIntegral (fromEnum (maxBound :: LicenseExceptionId))-        then fail "Too large LicenseExceptionId tag"-        else return (toEnum (fromIntegral i))---- note: remember to bump version each time the definition changes-instance Structured LicenseExceptionId where-    structure p = set typeVersion 306 $ nominalStructure p--instance Pretty LicenseExceptionId where-    pretty = Disp.text . licenseExceptionId--instance Parsec LicenseExceptionId where-    parsec = do-        n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.'-        v <- askCabalSpecVersion-        maybe (fail $ "Unknown SPDX license exception identifier: " ++ n) return $-            mkLicenseExceptionId (cabalSpecVersionToSPDXListVersion v) n--instance NFData LicenseExceptionId where-    rnf l = l `seq` ()------------------------------------------------------------------------------------ License Data------------------------------------------------------------------------------------ | License SPDX identifier, e.g. @"BSD-3-Clause"@.-licenseExceptionId :: LicenseExceptionId -> String-licenseExceptionId DS389_exception = "389-exception"-licenseExceptionId Autoconf_exception_2_0 = "Autoconf-exception-2.0"-licenseExceptionId Autoconf_exception_3_0 = "Autoconf-exception-3.0"-licenseExceptionId Bison_exception_2_2 = "Bison-exception-2.2"-licenseExceptionId Bootloader_exception = "Bootloader-exception"-licenseExceptionId Classpath_exception_2_0 = "Classpath-exception-2.0"-licenseExceptionId CLISP_exception_2_0 = "CLISP-exception-2.0"-licenseExceptionId DigiRule_FOSS_exception = "DigiRule-FOSS-exception"-licenseExceptionId ECos_exception_2_0 = "eCos-exception-2.0"-licenseExceptionId Fawkes_Runtime_exception = "Fawkes-Runtime-exception"-licenseExceptionId FLTK_exception = "FLTK-exception"-licenseExceptionId Font_exception_2_0 = "Font-exception-2.0"-licenseExceptionId Freertos_exception_2_0 = "freertos-exception-2.0"-licenseExceptionId GCC_exception_2_0 = "GCC-exception-2.0"-licenseExceptionId GCC_exception_3_1 = "GCC-exception-3.1"-licenseExceptionId Gnu_javamail_exception = "gnu-javamail-exception"-licenseExceptionId GPL_3_0_linking_exception = "GPL-3.0-linking-exception"-licenseExceptionId GPL_3_0_linking_source_exception = "GPL-3.0-linking-source-exception"-licenseExceptionId GPL_CC_1_0 = "GPL-CC-1.0"-licenseExceptionId I2p_gpl_java_exception = "i2p-gpl-java-exception"-licenseExceptionId LGPL_3_0_linking_exception = "LGPL-3.0-linking-exception"-licenseExceptionId Libtool_exception = "Libtool-exception"-licenseExceptionId Linux_syscall_note = "Linux-syscall-note"-licenseExceptionId LLVM_exception = "LLVM-exception"-licenseExceptionId LZMA_exception = "LZMA-exception"-licenseExceptionId Mif_exception = "mif-exception"-licenseExceptionId Nokia_Qt_exception_1_1 = "Nokia-Qt-exception-1.1"-licenseExceptionId OCaml_LGPL_linking_exception = "OCaml-LGPL-linking-exception"-licenseExceptionId OCCT_exception_1_0 = "OCCT-exception-1.0"-licenseExceptionId OpenJDK_assembly_exception_1_0 = "OpenJDK-assembly-exception-1.0"-licenseExceptionId Openvpn_openssl_exception = "openvpn-openssl-exception"-licenseExceptionId PS_or_PDF_font_exception_20170817 = "PS-or-PDF-font-exception-20170817"-licenseExceptionId Qt_GPL_exception_1_0 = "Qt-GPL-exception-1.0"-licenseExceptionId Qt_LGPL_exception_1_1 = "Qt-LGPL-exception-1.1"-licenseExceptionId Qwt_exception_1_0 = "Qwt-exception-1.0"-licenseExceptionId SHL_2_0 = "SHL-2.0"-licenseExceptionId SHL_2_1 = "SHL-2.1"-licenseExceptionId Swift_exception = "Swift-exception"-licenseExceptionId U_boot_exception_2_0 = "u-boot-exception-2.0"-licenseExceptionId Universal_FOSS_exception_1_0 = "Universal-FOSS-exception-1.0"-licenseExceptionId WxWindows_exception_3_1 = "WxWindows-exception-3.1"---- | License name, e.g. @"GNU General Public License v2.0 only"@-licenseExceptionName :: LicenseExceptionId -> String-licenseExceptionName DS389_exception = "389 Directory Server Exception"-licenseExceptionName Autoconf_exception_2_0 = "Autoconf exception 2.0"-licenseExceptionName Autoconf_exception_3_0 = "Autoconf exception 3.0"-licenseExceptionName Bison_exception_2_2 = "Bison exception 2.2"-licenseExceptionName Bootloader_exception = "Bootloader Distribution Exception"-licenseExceptionName Classpath_exception_2_0 = "Classpath exception 2.0"-licenseExceptionName CLISP_exception_2_0 = "CLISP exception 2.0"-licenseExceptionName DigiRule_FOSS_exception = "DigiRule FOSS License Exception"-licenseExceptionName ECos_exception_2_0 = "eCos exception 2.0"-licenseExceptionName Fawkes_Runtime_exception = "Fawkes Runtime Exception"-licenseExceptionName FLTK_exception = "FLTK exception"-licenseExceptionName Font_exception_2_0 = "Font exception 2.0"-licenseExceptionName Freertos_exception_2_0 = "FreeRTOS Exception 2.0"-licenseExceptionName GCC_exception_2_0 = "GCC Runtime Library exception 2.0"-licenseExceptionName GCC_exception_3_1 = "GCC Runtime Library exception 3.1"-licenseExceptionName Gnu_javamail_exception = "GNU JavaMail exception"-licenseExceptionName GPL_3_0_linking_exception = "GPL-3.0 Linking Exception"-licenseExceptionName GPL_3_0_linking_source_exception = "GPL-3.0 Linking Exception (with Corresponding Source)"-licenseExceptionName GPL_CC_1_0 = "GPL Cooperation Commitment 1.0"-licenseExceptionName I2p_gpl_java_exception = "i2p GPL+Java Exception"-licenseExceptionName LGPL_3_0_linking_exception = "LGPL-3.0 Linking Exception"-licenseExceptionName Libtool_exception = "Libtool Exception"-licenseExceptionName Linux_syscall_note = "Linux Syscall Note"-licenseExceptionName LLVM_exception = "LLVM Exception"-licenseExceptionName LZMA_exception = "LZMA exception"-licenseExceptionName Mif_exception = "Macros and Inline Functions Exception"-licenseExceptionName Nokia_Qt_exception_1_1 = "Nokia Qt LGPL exception 1.1"-licenseExceptionName OCaml_LGPL_linking_exception = "OCaml LGPL Linking Exception"-licenseExceptionName OCCT_exception_1_0 = "Open CASCADE Exception 1.0"-licenseExceptionName OpenJDK_assembly_exception_1_0 = "OpenJDK Assembly exception 1.0"-licenseExceptionName Openvpn_openssl_exception = "OpenVPN OpenSSL Exception"-licenseExceptionName PS_or_PDF_font_exception_20170817 = "PS/PDF font exception (2017-08-17)"-licenseExceptionName Qt_GPL_exception_1_0 = "Qt GPL exception 1.0"-licenseExceptionName Qt_LGPL_exception_1_1 = "Qt LGPL exception 1.1"-licenseExceptionName Qwt_exception_1_0 = "Qwt exception 1.0"-licenseExceptionName SHL_2_0 = "Solderpad Hardware License v2.0"-licenseExceptionName SHL_2_1 = "Solderpad Hardware License v2.1"-licenseExceptionName Swift_exception = "Swift Exception"-licenseExceptionName U_boot_exception_2_0 = "U-Boot exception 2.0"-licenseExceptionName Universal_FOSS_exception_1_0 = "Universal FOSS Exception, Version 1.0"-licenseExceptionName WxWindows_exception_3_1 = "WxWindows Library Exception 3.1"------------------------------------------------------------------------------------ Creation----------------------------------------------------------------------------------licenseExceptionIdList :: LicenseListVersion -> [LicenseExceptionId]-licenseExceptionIdList LicenseListVersion_3_0 =-    [ Nokia_Qt_exception_1_1-    ]-    ++ bulkOfLicenses-licenseExceptionIdList LicenseListVersion_3_2 =-    [ LLVM_exception-    , Nokia_Qt_exception_1_1-    , OpenJDK_assembly_exception_1_0-    , PS_or_PDF_font_exception_20170817-    , Qt_GPL_exception_1_0-    , Qt_LGPL_exception_1_1-    ]-    ++ bulkOfLicenses-licenseExceptionIdList LicenseListVersion_3_6 =-    [ GPL_CC_1_0-    , LLVM_exception-    , OCaml_LGPL_linking_exception-    , OpenJDK_assembly_exception_1_0-    , PS_or_PDF_font_exception_20170817-    , Qt_GPL_exception_1_0-    , Qt_LGPL_exception_1_1-    , Swift_exception-    , Universal_FOSS_exception_1_0-    ]-    ++ bulkOfLicenses-licenseExceptionIdList LicenseListVersion_3_9 =-    [ GPL_3_0_linking_exception-    , GPL_3_0_linking_source_exception-    , GPL_CC_1_0-    , LGPL_3_0_linking_exception-    , LLVM_exception-    , OCaml_LGPL_linking_exception-    , OpenJDK_assembly_exception_1_0-    , PS_or_PDF_font_exception_20170817-    , Qt_GPL_exception_1_0-    , Qt_LGPL_exception_1_1-    , SHL_2_0-    , SHL_2_1-    , Swift_exception-    , Universal_FOSS_exception_1_0-    ]-    ++ bulkOfLicenses-licenseExceptionIdList LicenseListVersion_3_10 =-    [ GPL_3_0_linking_exception-    , GPL_3_0_linking_source_exception-    , GPL_CC_1_0-    , LGPL_3_0_linking_exception-    , LLVM_exception-    , OCaml_LGPL_linking_exception-    , OpenJDK_assembly_exception_1_0-    , PS_or_PDF_font_exception_20170817-    , Qt_GPL_exception_1_0-    , Qt_LGPL_exception_1_1-    , SHL_2_0-    , SHL_2_1-    , Swift_exception-    , Universal_FOSS_exception_1_0-    ]-    ++ bulkOfLicenses---- | Create a 'LicenseExceptionId' from a 'String'.-mkLicenseExceptionId :: LicenseListVersion -> String -> Maybe LicenseExceptionId-mkLicenseExceptionId LicenseListVersion_3_0  s = Map.lookup s stringLookup_3_0-mkLicenseExceptionId LicenseListVersion_3_2  s = Map.lookup s stringLookup_3_2-mkLicenseExceptionId LicenseListVersion_3_6  s = Map.lookup s stringLookup_3_6-mkLicenseExceptionId LicenseListVersion_3_9  s = Map.lookup s stringLookup_3_9-mkLicenseExceptionId LicenseListVersion_3_10 s = Map.lookup s stringLookup_3_10--stringLookup_3_0 :: Map String LicenseExceptionId-stringLookup_3_0 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $-    licenseExceptionIdList LicenseListVersion_3_0--stringLookup_3_2 :: Map String LicenseExceptionId-stringLookup_3_2 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $-    licenseExceptionIdList LicenseListVersion_3_2--stringLookup_3_6 :: Map String LicenseExceptionId-stringLookup_3_6 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $-    licenseExceptionIdList LicenseListVersion_3_6--stringLookup_3_9 :: Map String LicenseExceptionId-stringLookup_3_9 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $-    licenseExceptionIdList LicenseListVersion_3_9--stringLookup_3_10 :: Map String LicenseExceptionId-stringLookup_3_10 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $-    licenseExceptionIdList LicenseListVersion_3_10----  | License exceptions in all SPDX License lists-bulkOfLicenses :: [LicenseExceptionId]-bulkOfLicenses =-    [ DS389_exception-    , Autoconf_exception_2_0-    , Autoconf_exception_3_0-    , Bison_exception_2_2-    , Bootloader_exception-    , Classpath_exception_2_0-    , CLISP_exception_2_0-    , DigiRule_FOSS_exception-    , ECos_exception_2_0-    , Fawkes_Runtime_exception-    , FLTK_exception-    , Font_exception_2_0-    , Freertos_exception_2_0-    , GCC_exception_2_0-    , GCC_exception_3_1-    , Gnu_javamail_exception-    , I2p_gpl_java_exception-    , Libtool_exception-    , Linux_syscall_note-    , LZMA_exception-    , Mif_exception-    , OCCT_exception_1_0-    , Openvpn_openssl_exception-    , Qwt_exception_1_0-    , U_boot_exception_2_0-    , WxWindows_exception_3_1-    ]
− src/Distribution/SPDX/LicenseExpression.hs 
@@ -1,162 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.SPDX.LicenseExpression (-    LicenseExpression (..),-    SimpleLicenseExpression (..),-    simpleLicenseExpression,-    ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty-import Distribution.SPDX.LicenseExceptionId-import Distribution.SPDX.LicenseId-import Distribution.SPDX.LicenseListVersion-import Distribution.SPDX.LicenseReference-import Distribution.Utils.Generic           (isAsciiAlphaNum)--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp---- | SPDX License Expression.------ @--- idstring              = 1*(ALPHA \/ DIGIT \/ "-" \/ "." )--- license id            = \<short form license identifier inAppendix I.1>--- license exception id  = \<short form license exception identifier inAppendix I.2>--- license ref           = [\"DocumentRef-"1*(idstring)":"]\"LicenseRef-"1*(idstring)------ simple expression     = license id \/ license id"+" \/ license ref------ compound expression   = 1*1(simple expression \/---                         simple expression \"WITH" license exception id \/---                         compound expression \"AND" compound expression \/---                         compound expression \"OR" compound expression ) \/---                         "(" compound expression ")" )------ license expression    = 1*1(simple expression / compound expression)--- @-data LicenseExpression-    = ELicense !SimpleLicenseExpression !(Maybe LicenseExceptionId)-    | EAnd !LicenseExpression !LicenseExpression-    | EOr !LicenseExpression !LicenseExpression-    deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)---- | Simple License Expressions.-data SimpleLicenseExpression-    = ELicenseId LicenseId-      -- ^ An SPDX License List Short Form Identifier. For example: @GPL-2.0-only@-    | ELicenseIdPlus LicenseId-      -- ^ An SPDX License List Short Form Identifier with a unary"+" operator suffix to represent the current version of the license or any later version.  For example: @GPL-2.0+@-    | ELicenseRef LicenseRef-      -- ^ A SPDX user defined license reference: For example: @LicenseRef-23@, @LicenseRef-MIT-Style-1@, or @DocumentRef-spdx-tool-1.2:LicenseRef-MIT-Style-2@-    deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)--simpleLicenseExpression :: LicenseId -> LicenseExpression-simpleLicenseExpression i = ELicense (ELicenseId i) Nothing--instance Binary LicenseExpression-instance Binary SimpleLicenseExpression-instance Structured SimpleLicenseExpression-instance Structured LicenseExpression--instance Pretty LicenseExpression where-    pretty = go 0-      where-        go :: Int -> LicenseExpression -> Disp.Doc-        go _ (ELicense lic exc) =-            let doc = pretty lic-            in maybe id (\e d -> d <+> Disp.text "WITH" <+> pretty e) exc doc-        go d (EAnd e1 e2) = parens (d < 0) $ go 0 e1 <+> Disp.text "AND" <+> go 0 e2-        go d (EOr  e1 e2) = parens (d < 1) $ go 1 e1 <+> Disp.text "OR" <+> go 1 e2---        parens False doc = doc-        parens True  doc = Disp.parens doc--instance Pretty SimpleLicenseExpression where-    pretty (ELicenseId i)     = pretty i-    pretty (ELicenseIdPlus i) = pretty i <<>> Disp.char '+'-    pretty (ELicenseRef r)    = pretty r--instance Parsec SimpleLicenseExpression where-    parsec = idstring >>= simple where-        simple n-            | Just l <- "LicenseRef-" `isPrefixOfMaybe` n =-                maybe (fail $ "Incorrect LicenseRef format: " ++ n) (return . ELicenseRef) $ mkLicenseRef Nothing l-            | Just d <- "DocumentRef-" `isPrefixOfMaybe` n = do-                _ <- P.string ":LicenseRef-"-                l <- idstring-                maybe (fail $ "Incorrect LicenseRef format:" ++ n) (return . ELicenseRef) $ mkLicenseRef (Just d) l-            | otherwise = do-                v <- askCabalSpecVersion-                l <- maybe (fail $ "Unknown SPDX license identifier: '" ++  n ++ "' " ++ licenseIdMigrationMessage n) return $-                    mkLicenseId (cabalSpecVersionToSPDXListVersion v) n-                orLater <- isJust <$> P.optional (P.char '+')-                if orLater-                then return (ELicenseIdPlus l)-                else return (ELicenseId l)--idstring :: P.CharParsing m => m String-idstring = P.munch1 $ \c -> isAsciiAlphaNum c || c == '-' || c == '.'---- returns suffix part-isPrefixOfMaybe :: Eq a => [a] -> [a] -> Maybe [a]-isPrefixOfMaybe pfx s-    | pfx `isPrefixOf` s = Just (drop (length pfx) s)-    | otherwise          = Nothing--instance Parsec LicenseExpression where-    parsec = expr-      where-        expr = compoundOr--        simple = do-            s <- parsec-            exc <- exception-            return $ ELicense s exc--        exception = P.optional $ P.try (spaces1 *> P.string "WITH" *> spaces1) *> parsec--        compoundOr = do-            x <- compoundAnd-            l <- P.optional $ P.try (spaces1 *> P.string "OR" *> spaces1) *> compoundOr-            return $ maybe id (flip EOr) l x--        compoundAnd = do-            x <- compound-            l <- P.optional $ P.try (spaces1 *> P.string "AND" *> spaces1) *> compoundAnd-            return $ maybe id (flip EAnd) l x--        compound = braces <|> simple--        -- NOTE: we require that there's a space around AND & OR operators,-        -- i.e. @(MIT)AND(MIT)@ will cause parse-error.-        braces = do-            _ <- P.char '('-            _ <- P.spaces-            x <- expr-            _ <- P.char ')'-            return x--        spaces1 = P.space *> P.spaces---- notes:------ There MUST NOT be whitespace between a license­id and any following "+".  This supports easy parsing and--- backwards compatibility.  There MUST be whitespace on either side of the operator "WITH".  There MUST be--- whitespace and/or parentheses on either side of the operators "AND" and "OR".------ We handle that by having greedy 'idstring' parser, so MITAND would parse as invalid license identifier.--instance NFData LicenseExpression where-    rnf (ELicense s e) = rnf s `seq` rnf e-    rnf (EAnd x y)     = rnf x `seq` rnf y-    rnf (EOr x y)      = rnf x `seq` rnf y--instance NFData SimpleLicenseExpression where-    rnf (ELicenseId i)     = rnf i-    rnf (ELicenseIdPlus i) = rnf i-    rnf (ELicenseRef r)    = rnf r
− src/Distribution/SPDX/LicenseId.hs 
@@ -1,2152 +0,0 @@--- This file is generated. See Makefile's spdx rule-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.SPDX.LicenseId (-    LicenseId (..),-    licenseId,-    licenseName,-    licenseIsOsiApproved,-    licenseIsFsfLibre,-    mkLicenseId,-    licenseIdList,-    -- * Helpers-    licenseIdMigrationMessage,-    ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Compat.Lens (set)-import Distribution.Pretty-import Distribution.Parsec-import Distribution.Utils.Generic (isAsciiAlphaNum)-import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion)-import Distribution.SPDX.LicenseListVersion--import qualified Data.Binary.Get as Binary-import qualified Data.Binary.Put as Binary-import qualified Data.Map.Strict as Map-import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp------------------------------------------------------------------------------------ LicenseId------------------------------------------------------------------------------------ | SPDX License identifier-data LicenseId-    = NullBSD -- ^ @0BSD@, BSD Zero Clause License-    | AAL -- ^ @AAL@, Attribution Assurance License-    | Abstyles -- ^ @Abstyles@, Abstyles License-    | Adobe_2006 -- ^ @Adobe-2006@, Adobe Systems Incorporated Source Code License Agreement-    | Adobe_Glyph -- ^ @Adobe-Glyph@, Adobe Glyph List License-    | ADSL -- ^ @ADSL@, Amazon Digital Services License-    | AFL_1_1 -- ^ @AFL-1.1@, Academic Free License v1.1-    | AFL_1_2 -- ^ @AFL-1.2@, Academic Free License v1.2-    | AFL_2_0 -- ^ @AFL-2.0@, Academic Free License v2.0-    | AFL_2_1 -- ^ @AFL-2.1@, Academic Free License v2.1-    | AFL_3_0 -- ^ @AFL-3.0@, Academic Free License v3.0-    | Afmparse -- ^ @Afmparse@, Afmparse License-    | AGPL_1_0 -- ^ @AGPL-1.0@, Affero General Public License v1.0, SPDX License List 3.0-    | AGPL_1_0_only -- ^ @AGPL-1.0-only@, Affero General Public License v1.0 only, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | AGPL_1_0_or_later -- ^ @AGPL-1.0-or-later@, Affero General Public License v1.0 or later, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | AGPL_3_0_only -- ^ @AGPL-3.0-only@, GNU Affero General Public License v3.0 only-    | AGPL_3_0_or_later -- ^ @AGPL-3.0-or-later@, GNU Affero General Public License v3.0 or later-    | Aladdin -- ^ @Aladdin@, Aladdin Free Public License-    | AMDPLPA -- ^ @AMDPLPA@, AMD's plpa_map.c License-    | AML -- ^ @AML@, Apple MIT License-    | AMPAS -- ^ @AMPAS@, Academy of Motion Picture Arts and Sciences BSD-    | ANTLR_PD -- ^ @ANTLR-PD@, ANTLR Software Rights Notice-    | Apache_1_0 -- ^ @Apache-1.0@, Apache License 1.0-    | Apache_1_1 -- ^ @Apache-1.1@, Apache License 1.1-    | Apache_2_0 -- ^ @Apache-2.0@, Apache License 2.0-    | APAFML -- ^ @APAFML@, Adobe Postscript AFM License-    | APL_1_0 -- ^ @APL-1.0@, Adaptive Public License 1.0-    | APSL_1_0 -- ^ @APSL-1.0@, Apple Public Source License 1.0-    | APSL_1_1 -- ^ @APSL-1.1@, Apple Public Source License 1.1-    | APSL_1_2 -- ^ @APSL-1.2@, Apple Public Source License 1.2-    | APSL_2_0 -- ^ @APSL-2.0@, Apple Public Source License 2.0-    | Artistic_1_0_cl8 -- ^ @Artistic-1.0-cl8@, Artistic License 1.0 w/clause 8-    | Artistic_1_0_Perl -- ^ @Artistic-1.0-Perl@, Artistic License 1.0 (Perl)-    | Artistic_1_0 -- ^ @Artistic-1.0@, Artistic License 1.0-    | Artistic_2_0 -- ^ @Artistic-2.0@, Artistic License 2.0-    | Bahyph -- ^ @Bahyph@, Bahyph License-    | Barr -- ^ @Barr@, Barr License-    | Beerware -- ^ @Beerware@, Beerware License-    | BitTorrent_1_0 -- ^ @BitTorrent-1.0@, BitTorrent Open Source License v1.0-    | BitTorrent_1_1 -- ^ @BitTorrent-1.1@, BitTorrent Open Source License v1.1-    | Blessing -- ^ @blessing@, SQLite Blessing, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | BlueOak_1_0_0 -- ^ @BlueOak-1.0.0@, Blue Oak Model License 1.0.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | Borceux -- ^ @Borceux@, Borceux license-    | BSD_1_Clause -- ^ @BSD-1-Clause@, BSD 1-Clause License-    | BSD_2_Clause_FreeBSD -- ^ @BSD-2-Clause-FreeBSD@, BSD 2-Clause FreeBSD License, SPDX License List 3.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9-    | BSD_2_Clause_NetBSD -- ^ @BSD-2-Clause-NetBSD@, BSD 2-Clause NetBSD License, SPDX License List 3.0, SPDX License List 3.2, SPDX License List 3.6-    | BSD_2_Clause_Patent -- ^ @BSD-2-Clause-Patent@, BSD-2-Clause Plus Patent License-    | BSD_2_Clause_Views -- ^ @BSD-2-Clause-Views@, BSD 2-Clause with views sentence, SPDX License List 3.10-    | BSD_2_Clause -- ^ @BSD-2-Clause@, BSD 2-Clause "Simplified" License-    | BSD_3_Clause_Attribution -- ^ @BSD-3-Clause-Attribution@, BSD with attribution-    | BSD_3_Clause_Clear -- ^ @BSD-3-Clause-Clear@, BSD 3-Clause Clear License-    | BSD_3_Clause_LBNL -- ^ @BSD-3-Clause-LBNL@, Lawrence Berkeley National Labs BSD variant license-    | BSD_3_Clause_No_Nuclear_License_2014 -- ^ @BSD-3-Clause-No-Nuclear-License-2014@, BSD 3-Clause No Nuclear License 2014-    | BSD_3_Clause_No_Nuclear_License -- ^ @BSD-3-Clause-No-Nuclear-License@, BSD 3-Clause No Nuclear License-    | BSD_3_Clause_No_Nuclear_Warranty -- ^ @BSD-3-Clause-No-Nuclear-Warranty@, BSD 3-Clause No Nuclear Warranty-    | BSD_3_Clause_Open_MPI -- ^ @BSD-3-Clause-Open-MPI@, BSD 3-Clause Open MPI variant, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | BSD_3_Clause -- ^ @BSD-3-Clause@, BSD 3-Clause "New" or "Revised" License-    | BSD_4_Clause_UC -- ^ @BSD-4-Clause-UC@, BSD-4-Clause (University of California-Specific)-    | BSD_4_Clause -- ^ @BSD-4-Clause@, BSD 4-Clause "Original" or "Old" License-    | BSD_Protection -- ^ @BSD-Protection@, BSD Protection License-    | BSD_Source_Code -- ^ @BSD-Source-Code@, BSD Source Code Attribution-    | BSL_1_0 -- ^ @BSL-1.0@, Boost Software License 1.0-    | Bzip2_1_0_5 -- ^ @bzip2-1.0.5@, bzip2 and libbzip2 License v1.0.5-    | Bzip2_1_0_6 -- ^ @bzip2-1.0.6@, bzip2 and libbzip2 License v1.0.6-    | CAL_1_0_Combined_Work_Exception -- ^ @CAL-1.0-Combined-Work-Exception@, Cryptographic Autonomy License 1.0 (Combined Work Exception), SPDX License List 3.9, SPDX License List 3.10-    | CAL_1_0 -- ^ @CAL-1.0@, Cryptographic Autonomy License 1.0, SPDX License List 3.9, SPDX License List 3.10-    | Caldera -- ^ @Caldera@, Caldera License-    | CATOSL_1_1 -- ^ @CATOSL-1.1@, Computer Associates Trusted Open Source License 1.1-    | CC_BY_1_0 -- ^ @CC-BY-1.0@, Creative Commons Attribution 1.0 Generic-    | CC_BY_2_0 -- ^ @CC-BY-2.0@, Creative Commons Attribution 2.0 Generic-    | CC_BY_2_5 -- ^ @CC-BY-2.5@, Creative Commons Attribution 2.5 Generic-    | CC_BY_3_0_AT -- ^ @CC-BY-3.0-AT@, Creative Commons Attribution 3.0 Austria, SPDX License List 3.10-    | CC_BY_3_0 -- ^ @CC-BY-3.0@, Creative Commons Attribution 3.0 Unported-    | CC_BY_4_0 -- ^ @CC-BY-4.0@, Creative Commons Attribution 4.0 International-    | CC_BY_NC_1_0 -- ^ @CC-BY-NC-1.0@, Creative Commons Attribution Non Commercial 1.0 Generic-    | CC_BY_NC_2_0 -- ^ @CC-BY-NC-2.0@, Creative Commons Attribution Non Commercial 2.0 Generic-    | CC_BY_NC_2_5 -- ^ @CC-BY-NC-2.5@, Creative Commons Attribution Non Commercial 2.5 Generic-    | CC_BY_NC_3_0 -- ^ @CC-BY-NC-3.0@, Creative Commons Attribution Non Commercial 3.0 Unported-    | CC_BY_NC_4_0 -- ^ @CC-BY-NC-4.0@, Creative Commons Attribution Non Commercial 4.0 International-    | CC_BY_NC_ND_1_0 -- ^ @CC-BY-NC-ND-1.0@, Creative Commons Attribution Non Commercial No Derivatives 1.0 Generic-    | CC_BY_NC_ND_2_0 -- ^ @CC-BY-NC-ND-2.0@, Creative Commons Attribution Non Commercial No Derivatives 2.0 Generic-    | CC_BY_NC_ND_2_5 -- ^ @CC-BY-NC-ND-2.5@, Creative Commons Attribution Non Commercial No Derivatives 2.5 Generic-    | CC_BY_NC_ND_3_0_IGO -- ^ @CC-BY-NC-ND-3.0-IGO@, Creative Commons Attribution Non Commercial No Derivatives 3.0 IGO, SPDX License List 3.10-    | CC_BY_NC_ND_3_0 -- ^ @CC-BY-NC-ND-3.0@, Creative Commons Attribution Non Commercial No Derivatives 3.0 Unported-    | CC_BY_NC_ND_4_0 -- ^ @CC-BY-NC-ND-4.0@, Creative Commons Attribution Non Commercial No Derivatives 4.0 International-    | CC_BY_NC_SA_1_0 -- ^ @CC-BY-NC-SA-1.0@, Creative Commons Attribution Non Commercial Share Alike 1.0 Generic-    | CC_BY_NC_SA_2_0 -- ^ @CC-BY-NC-SA-2.0@, Creative Commons Attribution Non Commercial Share Alike 2.0 Generic-    | CC_BY_NC_SA_2_5 -- ^ @CC-BY-NC-SA-2.5@, Creative Commons Attribution Non Commercial Share Alike 2.5 Generic-    | CC_BY_NC_SA_3_0 -- ^ @CC-BY-NC-SA-3.0@, Creative Commons Attribution Non Commercial Share Alike 3.0 Unported-    | CC_BY_NC_SA_4_0 -- ^ @CC-BY-NC-SA-4.0@, Creative Commons Attribution Non Commercial Share Alike 4.0 International-    | CC_BY_ND_1_0 -- ^ @CC-BY-ND-1.0@, Creative Commons Attribution No Derivatives 1.0 Generic-    | CC_BY_ND_2_0 -- ^ @CC-BY-ND-2.0@, Creative Commons Attribution No Derivatives 2.0 Generic-    | CC_BY_ND_2_5 -- ^ @CC-BY-ND-2.5@, Creative Commons Attribution No Derivatives 2.5 Generic-    | CC_BY_ND_3_0 -- ^ @CC-BY-ND-3.0@, Creative Commons Attribution No Derivatives 3.0 Unported-    | CC_BY_ND_4_0 -- ^ @CC-BY-ND-4.0@, Creative Commons Attribution No Derivatives 4.0 International-    | CC_BY_SA_1_0 -- ^ @CC-BY-SA-1.0@, Creative Commons Attribution Share Alike 1.0 Generic-    | CC_BY_SA_2_0 -- ^ @CC-BY-SA-2.0@, Creative Commons Attribution Share Alike 2.0 Generic-    | CC_BY_SA_2_5 -- ^ @CC-BY-SA-2.5@, Creative Commons Attribution Share Alike 2.5 Generic-    | CC_BY_SA_3_0_AT -- ^ @CC-BY-SA-3.0-AT@, Creative Commons Attribution-Share Alike 3.0 Austria, SPDX License List 3.10-    | CC_BY_SA_3_0 -- ^ @CC-BY-SA-3.0@, Creative Commons Attribution Share Alike 3.0 Unported-    | CC_BY_SA_4_0 -- ^ @CC-BY-SA-4.0@, Creative Commons Attribution Share Alike 4.0 International-    | CC_PDDC -- ^ @CC-PDDC@, Creative Commons Public Domain Dedication and Certification, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | CC0_1_0 -- ^ @CC0-1.0@, Creative Commons Zero v1.0 Universal-    | CDDL_1_0 -- ^ @CDDL-1.0@, Common Development and Distribution License 1.0-    | CDDL_1_1 -- ^ @CDDL-1.1@, Common Development and Distribution License 1.1-    | CDLA_Permissive_1_0 -- ^ @CDLA-Permissive-1.0@, Community Data License Agreement Permissive 1.0-    | CDLA_Sharing_1_0 -- ^ @CDLA-Sharing-1.0@, Community Data License Agreement Sharing 1.0-    | CECILL_1_0 -- ^ @CECILL-1.0@, CeCILL Free Software License Agreement v1.0-    | CECILL_1_1 -- ^ @CECILL-1.1@, CeCILL Free Software License Agreement v1.1-    | CECILL_2_0 -- ^ @CECILL-2.0@, CeCILL Free Software License Agreement v2.0-    | CECILL_2_1 -- ^ @CECILL-2.1@, CeCILL Free Software License Agreement v2.1-    | CECILL_B -- ^ @CECILL-B@, CeCILL-B Free Software License Agreement-    | CECILL_C -- ^ @CECILL-C@, CeCILL-C Free Software License Agreement-    | CERN_OHL_1_1 -- ^ @CERN-OHL-1.1@, CERN Open Hardware Licence v1.1, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | CERN_OHL_1_2 -- ^ @CERN-OHL-1.2@, CERN Open Hardware Licence v1.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | CERN_OHL_P_2_0 -- ^ @CERN-OHL-P-2.0@, CERN Open Hardware Licence Version 2 - Permissive, SPDX License List 3.9, SPDX License List 3.10-    | CERN_OHL_S_2_0 -- ^ @CERN-OHL-S-2.0@, CERN Open Hardware Licence Version 2 - Strongly Reciprocal, SPDX License List 3.9, SPDX License List 3.10-    | CERN_OHL_W_2_0 -- ^ @CERN-OHL-W-2.0@, CERN Open Hardware Licence Version 2 - Weakly Reciprocal, SPDX License List 3.9, SPDX License List 3.10-    | ClArtistic -- ^ @ClArtistic@, Clarified Artistic License-    | CNRI_Jython -- ^ @CNRI-Jython@, CNRI Jython License-    | CNRI_Python_GPL_Compatible -- ^ @CNRI-Python-GPL-Compatible@, CNRI Python Open Source GPL Compatible License Agreement-    | CNRI_Python -- ^ @CNRI-Python@, CNRI Python License-    | Condor_1_1 -- ^ @Condor-1.1@, Condor Public License v1.1-    | Copyleft_next_0_3_0 -- ^ @copyleft-next-0.3.0@, copyleft-next 0.3.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | Copyleft_next_0_3_1 -- ^ @copyleft-next-0.3.1@, copyleft-next 0.3.1, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | CPAL_1_0 -- ^ @CPAL-1.0@, Common Public Attribution License 1.0-    | CPL_1_0 -- ^ @CPL-1.0@, Common Public License 1.0-    | CPOL_1_02 -- ^ @CPOL-1.02@, Code Project Open License 1.02-    | Crossword -- ^ @Crossword@, Crossword License-    | CrystalStacker -- ^ @CrystalStacker@, CrystalStacker License-    | CUA_OPL_1_0 -- ^ @CUA-OPL-1.0@, CUA Office Public License v1.0-    | Cube -- ^ @Cube@, Cube License-    | Curl -- ^ @curl@, curl License-    | D_FSL_1_0 -- ^ @D-FSL-1.0@, Deutsche Freie Software Lizenz-    | Diffmark -- ^ @diffmark@, diffmark license-    | DOC -- ^ @DOC@, DOC License-    | Dotseqn -- ^ @Dotseqn@, Dotseqn License-    | DSDP -- ^ @DSDP@, DSDP License-    | Dvipdfm -- ^ @dvipdfm@, dvipdfm License-    | ECL_1_0 -- ^ @ECL-1.0@, Educational Community License v1.0-    | ECL_2_0 -- ^ @ECL-2.0@, Educational Community License v2.0-    | EFL_1_0 -- ^ @EFL-1.0@, Eiffel Forum License v1.0-    | EFL_2_0 -- ^ @EFL-2.0@, Eiffel Forum License v2.0-    | EGenix -- ^ @eGenix@, eGenix.com Public License 1.1.0-    | Entessa -- ^ @Entessa@, Entessa Public License v1.0-    | EPICS -- ^ @EPICS@, EPICS Open License, SPDX License List 3.10-    | EPL_1_0 -- ^ @EPL-1.0@, Eclipse Public License 1.0-    | EPL_2_0 -- ^ @EPL-2.0@, Eclipse Public License 2.0-    | ErlPL_1_1 -- ^ @ErlPL-1.1@, Erlang Public License v1.1-    | Etalab_2_0 -- ^ @etalab-2.0@, Etalab Open License 2.0, SPDX License List 3.9, SPDX License List 3.10-    | EUDatagrid -- ^ @EUDatagrid@, EU DataGrid Software License-    | EUPL_1_0 -- ^ @EUPL-1.0@, European Union Public License 1.0-    | EUPL_1_1 -- ^ @EUPL-1.1@, European Union Public License 1.1-    | EUPL_1_2 -- ^ @EUPL-1.2@, European Union Public License 1.2-    | Eurosym -- ^ @Eurosym@, Eurosym License-    | Fair -- ^ @Fair@, Fair License-    | Frameworx_1_0 -- ^ @Frameworx-1.0@, Frameworx Open License 1.0-    | FreeImage -- ^ @FreeImage@, FreeImage Public License v1.0-    | FSFAP -- ^ @FSFAP@, FSF All Permissive License-    | FSFULLR -- ^ @FSFULLR@, FSF Unlimited License (with License Retention)-    | FSFUL -- ^ @FSFUL@, FSF Unlimited License-    | FTL -- ^ @FTL@, Freetype Project License-    | GFDL_1_1_invariants_only -- ^ @GFDL-1.1-invariants-only@, GNU Free Documentation License v1.1 only - invariants, SPDX License List 3.10-    | GFDL_1_1_invariants_or_later -- ^ @GFDL-1.1-invariants-or-later@, GNU Free Documentation License v1.1 or later - invariants, SPDX License List 3.10-    | GFDL_1_1_no_invariants_only -- ^ @GFDL-1.1-no-invariants-only@, GNU Free Documentation License v1.1 only - no invariants, SPDX License List 3.10-    | GFDL_1_1_no_invariants_or_later -- ^ @GFDL-1.1-no-invariants-or-later@, GNU Free Documentation License v1.1 or later - no invariants, SPDX License List 3.10-    | GFDL_1_1_only -- ^ @GFDL-1.1-only@, GNU Free Documentation License v1.1 only-    | GFDL_1_1_or_later -- ^ @GFDL-1.1-or-later@, GNU Free Documentation License v1.1 or later-    | GFDL_1_2_invariants_only -- ^ @GFDL-1.2-invariants-only@, GNU Free Documentation License v1.2 only - invariants, SPDX License List 3.10-    | GFDL_1_2_invariants_or_later -- ^ @GFDL-1.2-invariants-or-later@, GNU Free Documentation License v1.2 or later - invariants, SPDX License List 3.10-    | GFDL_1_2_no_invariants_only -- ^ @GFDL-1.2-no-invariants-only@, GNU Free Documentation License v1.2 only - no invariants, SPDX License List 3.10-    | GFDL_1_2_no_invariants_or_later -- ^ @GFDL-1.2-no-invariants-or-later@, GNU Free Documentation License v1.2 or later - no invariants, SPDX License List 3.10-    | GFDL_1_2_only -- ^ @GFDL-1.2-only@, GNU Free Documentation License v1.2 only-    | GFDL_1_2_or_later -- ^ @GFDL-1.2-or-later@, GNU Free Documentation License v1.2 or later-    | GFDL_1_3_invariants_only -- ^ @GFDL-1.3-invariants-only@, GNU Free Documentation License v1.3 only - invariants, SPDX License List 3.10-    | GFDL_1_3_invariants_or_later -- ^ @GFDL-1.3-invariants-or-later@, GNU Free Documentation License v1.3 or later - invariants, SPDX License List 3.10-    | GFDL_1_3_no_invariants_only -- ^ @GFDL-1.3-no-invariants-only@, GNU Free Documentation License v1.3 only - no invariants, SPDX License List 3.10-    | GFDL_1_3_no_invariants_or_later -- ^ @GFDL-1.3-no-invariants-or-later@, GNU Free Documentation License v1.3 or later - no invariants, SPDX License List 3.10-    | GFDL_1_3_only -- ^ @GFDL-1.3-only@, GNU Free Documentation License v1.3 only-    | GFDL_1_3_or_later -- ^ @GFDL-1.3-or-later@, GNU Free Documentation License v1.3 or later-    | Giftware -- ^ @Giftware@, Giftware License-    | GL2PS -- ^ @GL2PS@, GL2PS License-    | Glide -- ^ @Glide@, 3dfx Glide License-    | Glulxe -- ^ @Glulxe@, Glulxe License-    | GLWTPL -- ^ @GLWTPL@, Good Luck With That Public License, SPDX License List 3.10-    | Gnuplot -- ^ @gnuplot@, gnuplot License-    | GPL_1_0_only -- ^ @GPL-1.0-only@, GNU General Public License v1.0 only-    | GPL_1_0_or_later -- ^ @GPL-1.0-or-later@, GNU General Public License v1.0 or later-    | GPL_2_0_only -- ^ @GPL-2.0-only@, GNU General Public License v2.0 only-    | GPL_2_0_or_later -- ^ @GPL-2.0-or-later@, GNU General Public License v2.0 or later-    | GPL_3_0_only -- ^ @GPL-3.0-only@, GNU General Public License v3.0 only-    | GPL_3_0_or_later -- ^ @GPL-3.0-or-later@, GNU General Public License v3.0 or later-    | GSOAP_1_3b -- ^ @gSOAP-1.3b@, gSOAP Public License v1.3b-    | HaskellReport -- ^ @HaskellReport@, Haskell Language Report License-    | Hippocratic_2_1 -- ^ @Hippocratic-2.1@, Hippocratic License 2.1, SPDX License List 3.9, SPDX License List 3.10-    | HPND_sell_variant -- ^ @HPND-sell-variant@, Historical Permission Notice and Disclaimer - sell variant, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | HPND -- ^ @HPND@, Historical Permission Notice and Disclaimer-    | IBM_pibs -- ^ @IBM-pibs@, IBM PowerPC Initialization and Boot Software-    | ICU -- ^ @ICU@, ICU License-    | IJG -- ^ @IJG@, Independent JPEG Group License-    | ImageMagick -- ^ @ImageMagick@, ImageMagick License-    | IMatix -- ^ @iMatix@, iMatix Standard Function Library Agreement-    | Imlib2 -- ^ @Imlib2@, Imlib2 License-    | Info_ZIP -- ^ @Info-ZIP@, Info-ZIP License-    | Intel_ACPI -- ^ @Intel-ACPI@, Intel ACPI Software License Agreement-    | Intel -- ^ @Intel@, Intel Open Source License-    | Interbase_1_0 -- ^ @Interbase-1.0@, Interbase Public License v1.0-    | IPA -- ^ @IPA@, IPA Font License-    | IPL_1_0 -- ^ @IPL-1.0@, IBM Public License v1.0-    | ISC -- ^ @ISC@, ISC License-    | JasPer_2_0 -- ^ @JasPer-2.0@, JasPer License-    | JPNIC -- ^ @JPNIC@, Japan Network Information Center License, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | JSON -- ^ @JSON@, JSON License-    | LAL_1_2 -- ^ @LAL-1.2@, Licence Art Libre 1.2-    | LAL_1_3 -- ^ @LAL-1.3@, Licence Art Libre 1.3-    | Latex2e -- ^ @Latex2e@, Latex2e License-    | Leptonica -- ^ @Leptonica@, Leptonica License-    | LGPL_2_0_only -- ^ @LGPL-2.0-only@, GNU Library General Public License v2 only-    | LGPL_2_0_or_later -- ^ @LGPL-2.0-or-later@, GNU Library General Public License v2 or later-    | LGPL_2_1_only -- ^ @LGPL-2.1-only@, GNU Lesser General Public License v2.1 only-    | LGPL_2_1_or_later -- ^ @LGPL-2.1-or-later@, GNU Lesser General Public License v2.1 or later-    | LGPL_3_0_only -- ^ @LGPL-3.0-only@, GNU Lesser General Public License v3.0 only-    | LGPL_3_0_or_later -- ^ @LGPL-3.0-or-later@, GNU Lesser General Public License v3.0 or later-    | LGPLLR -- ^ @LGPLLR@, Lesser General Public License For Linguistic Resources-    | Libpng_2_0 -- ^ @libpng-2.0@, PNG Reference Library version 2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | Libpng -- ^ @Libpng@, libpng License-    | Libselinux_1_0 -- ^ @libselinux-1.0@, libselinux public domain notice, SPDX License List 3.9, SPDX License List 3.10-    | Libtiff -- ^ @libtiff@, libtiff License-    | LiLiQ_P_1_1 -- ^ @LiLiQ-P-1.1@, Licence Libre du Québec – Permissive version 1.1-    | LiLiQ_R_1_1 -- ^ @LiLiQ-R-1.1@, Licence Libre du Québec – Réciprocité version 1.1-    | LiLiQ_Rplus_1_1 -- ^ @LiLiQ-Rplus-1.1@, Licence Libre du Québec – Réciprocité forte version 1.1-    | Linux_OpenIB -- ^ @Linux-OpenIB@, Linux Kernel Variant of OpenIB.org license, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | LPL_1_02 -- ^ @LPL-1.02@, Lucent Public License v1.02-    | LPL_1_0 -- ^ @LPL-1.0@, Lucent Public License Version 1.0-    | LPPL_1_0 -- ^ @LPPL-1.0@, LaTeX Project Public License v1.0-    | LPPL_1_1 -- ^ @LPPL-1.1@, LaTeX Project Public License v1.1-    | LPPL_1_2 -- ^ @LPPL-1.2@, LaTeX Project Public License v1.2-    | LPPL_1_3a -- ^ @LPPL-1.3a@, LaTeX Project Public License v1.3a-    | LPPL_1_3c -- ^ @LPPL-1.3c@, LaTeX Project Public License v1.3c-    | MakeIndex -- ^ @MakeIndex@, MakeIndex License-    | MirOS -- ^ @MirOS@, The MirOS Licence-    | MIT_0 -- ^ @MIT-0@, MIT No Attribution, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | MIT_advertising -- ^ @MIT-advertising@, Enlightenment License (e16)-    | MIT_CMU -- ^ @MIT-CMU@, CMU License-    | MIT_enna -- ^ @MIT-enna@, enna License-    | MIT_feh -- ^ @MIT-feh@, feh License-    | MITNFA -- ^ @MITNFA@, MIT +no-false-attribs license-    | MIT -- ^ @MIT@, MIT License-    | Motosoto -- ^ @Motosoto@, Motosoto License-    | Mpich2 -- ^ @mpich2@, mpich2 License-    | MPL_1_0 -- ^ @MPL-1.0@, Mozilla Public License 1.0-    | MPL_1_1 -- ^ @MPL-1.1@, Mozilla Public License 1.1-    | MPL_2_0_no_copyleft_exception -- ^ @MPL-2.0-no-copyleft-exception@, Mozilla Public License 2.0 (no copyleft exception)-    | MPL_2_0 -- ^ @MPL-2.0@, Mozilla Public License 2.0-    | MS_PL -- ^ @MS-PL@, Microsoft Public License-    | MS_RL -- ^ @MS-RL@, Microsoft Reciprocal License-    | MTLL -- ^ @MTLL@, Matrix Template Library License-    | MulanPSL_1_0 -- ^ @MulanPSL-1.0@, Mulan Permissive Software License, Version 1, SPDX License List 3.9, SPDX License List 3.10-    | MulanPSL_2_0 -- ^ @MulanPSL-2.0@, Mulan Permissive Software License, Version 2, SPDX License List 3.9, SPDX License List 3.10-    | Multics -- ^ @Multics@, Multics License-    | Mup -- ^ @Mup@, Mup License-    | NASA_1_3 -- ^ @NASA-1.3@, NASA Open Source Agreement 1.3-    | Naumen -- ^ @Naumen@, Naumen Public License-    | NBPL_1_0 -- ^ @NBPL-1.0@, Net Boolean Public License v1-    | NCGL_UK_2_0 -- ^ @NCGL-UK-2.0@, Non-Commercial Government Licence, SPDX License List 3.9, SPDX License List 3.10-    | NCSA -- ^ @NCSA@, University of Illinois/NCSA Open Source License-    | Net_SNMP -- ^ @Net-SNMP@, Net-SNMP License-    | NetCDF -- ^ @NetCDF@, NetCDF license-    | Newsletr -- ^ @Newsletr@, Newsletr License-    | NGPL -- ^ @NGPL@, Nethack General Public License-    | NIST_PD_fallback -- ^ @NIST-PD-fallback@, NIST Public Domain Notice with license fallback, SPDX License List 3.10-    | NIST_PD -- ^ @NIST-PD@, NIST Public Domain Notice, SPDX License List 3.10-    | NLOD_1_0 -- ^ @NLOD-1.0@, Norwegian Licence for Open Government Data-    | NLPL -- ^ @NLPL@, No Limit Public License-    | Nokia -- ^ @Nokia@, Nokia Open Source License-    | NOSL -- ^ @NOSL@, Netizen Open Source License-    | Noweb -- ^ @Noweb@, Noweb License-    | NPL_1_0 -- ^ @NPL-1.0@, Netscape Public License v1.0-    | NPL_1_1 -- ^ @NPL-1.1@, Netscape Public License v1.1-    | NPOSL_3_0 -- ^ @NPOSL-3.0@, Non-Profit Open Software License 3.0-    | NRL -- ^ @NRL@, NRL License-    | NTP_0 -- ^ @NTP-0@, NTP No Attribution, SPDX License List 3.9, SPDX License List 3.10-    | NTP -- ^ @NTP@, NTP License-    | O_UDA_1_0 -- ^ @O-UDA-1.0@, Open Use of Data Agreement v1.0, SPDX License List 3.9, SPDX License List 3.10-    | OCCT_PL -- ^ @OCCT-PL@, Open CASCADE Technology Public License-    | OCLC_2_0 -- ^ @OCLC-2.0@, OCLC Research Public License 2.0-    | ODbL_1_0 -- ^ @ODbL-1.0@, ODC Open Database License v1.0-    | ODC_By_1_0 -- ^ @ODC-By-1.0@, Open Data Commons Attribution License v1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | OFL_1_0_no_RFN -- ^ @OFL-1.0-no-RFN@, SIL Open Font License 1.0 with no Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10-    | OFL_1_0_RFN -- ^ @OFL-1.0-RFN@, SIL Open Font License 1.0 with Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10-    | OFL_1_0 -- ^ @OFL-1.0@, SIL Open Font License 1.0-    | OFL_1_1_no_RFN -- ^ @OFL-1.1-no-RFN@, SIL Open Font License 1.1 with no Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10-    | OFL_1_1_RFN -- ^ @OFL-1.1-RFN@, SIL Open Font License 1.1 with Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10-    | OFL_1_1 -- ^ @OFL-1.1@, SIL Open Font License 1.1-    | OGC_1_0 -- ^ @OGC-1.0@, OGC Software License, Version 1.0, SPDX License List 3.9, SPDX License List 3.10-    | OGL_Canada_2_0 -- ^ @OGL-Canada-2.0@, Open Government Licence - Canada, SPDX License List 3.9, SPDX License List 3.10-    | OGL_UK_1_0 -- ^ @OGL-UK-1.0@, Open Government Licence v1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | OGL_UK_2_0 -- ^ @OGL-UK-2.0@, Open Government Licence v2.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | OGL_UK_3_0 -- ^ @OGL-UK-3.0@, Open Government Licence v3.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | OGTSL -- ^ @OGTSL@, Open Group Test Suite License-    | OLDAP_1_1 -- ^ @OLDAP-1.1@, Open LDAP Public License v1.1-    | OLDAP_1_2 -- ^ @OLDAP-1.2@, Open LDAP Public License v1.2-    | OLDAP_1_3 -- ^ @OLDAP-1.3@, Open LDAP Public License v1.3-    | OLDAP_1_4 -- ^ @OLDAP-1.4@, Open LDAP Public License v1.4-    | OLDAP_2_0_1 -- ^ @OLDAP-2.0.1@, Open LDAP Public License v2.0.1-    | OLDAP_2_0 -- ^ @OLDAP-2.0@, Open LDAP Public License v2.0 (or possibly 2.0A and 2.0B)-    | OLDAP_2_1 -- ^ @OLDAP-2.1@, Open LDAP Public License v2.1-    | OLDAP_2_2_1 -- ^ @OLDAP-2.2.1@, Open LDAP Public License v2.2.1-    | OLDAP_2_2_2 -- ^ @OLDAP-2.2.2@, Open LDAP Public License 2.2.2-    | OLDAP_2_2 -- ^ @OLDAP-2.2@, Open LDAP Public License v2.2-    | OLDAP_2_3 -- ^ @OLDAP-2.3@, Open LDAP Public License v2.3-    | OLDAP_2_4 -- ^ @OLDAP-2.4@, Open LDAP Public License v2.4-    | OLDAP_2_5 -- ^ @OLDAP-2.5@, Open LDAP Public License v2.5-    | OLDAP_2_6 -- ^ @OLDAP-2.6@, Open LDAP Public License v2.6-    | OLDAP_2_7 -- ^ @OLDAP-2.7@, Open LDAP Public License v2.7-    | OLDAP_2_8 -- ^ @OLDAP-2.8@, Open LDAP Public License v2.8-    | OML -- ^ @OML@, Open Market License-    | OpenSSL -- ^ @OpenSSL@, OpenSSL License-    | OPL_1_0 -- ^ @OPL-1.0@, Open Public License v1.0-    | OSET_PL_2_1 -- ^ @OSET-PL-2.1@, OSET Public License version 2.1-    | OSL_1_0 -- ^ @OSL-1.0@, Open Software License 1.0-    | OSL_1_1 -- ^ @OSL-1.1@, Open Software License 1.1-    | OSL_2_0 -- ^ @OSL-2.0@, Open Software License 2.0-    | OSL_2_1 -- ^ @OSL-2.1@, Open Software License 2.1-    | OSL_3_0 -- ^ @OSL-3.0@, Open Software License 3.0-    | Parity_6_0_0 -- ^ @Parity-6.0.0@, The Parity Public License 6.0.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | Parity_7_0_0 -- ^ @Parity-7.0.0@, The Parity Public License 7.0.0, SPDX License List 3.9, SPDX License List 3.10-    | PDDL_1_0 -- ^ @PDDL-1.0@, ODC Public Domain Dedication & License 1.0-    | PHP_3_01 -- ^ @PHP-3.01@, PHP License v3.01-    | PHP_3_0 -- ^ @PHP-3.0@, PHP License v3.0-    | Plexus -- ^ @Plexus@, Plexus Classworlds License-    | PolyForm_Noncommercial_1_0_0 -- ^ @PolyForm-Noncommercial-1.0.0@, PolyForm Noncommercial License 1.0.0, SPDX License List 3.9, SPDX License List 3.10-    | PolyForm_Small_Business_1_0_0 -- ^ @PolyForm-Small-Business-1.0.0@, PolyForm Small Business License 1.0.0, SPDX License List 3.9, SPDX License List 3.10-    | PostgreSQL -- ^ @PostgreSQL@, PostgreSQL License-    | PSF_2_0 -- ^ @PSF-2.0@, Python Software Foundation License 2.0, SPDX License List 3.9, SPDX License List 3.10-    | Psfrag -- ^ @psfrag@, psfrag License-    | Psutils -- ^ @psutils@, psutils License-    | Python_2_0 -- ^ @Python-2.0@, Python License 2.0-    | Qhull -- ^ @Qhull@, Qhull License-    | QPL_1_0 -- ^ @QPL-1.0@, Q Public License 1.0-    | Rdisc -- ^ @Rdisc@, Rdisc License-    | RHeCos_1_1 -- ^ @RHeCos-1.1@, Red Hat eCos Public License v1.1-    | RPL_1_1 -- ^ @RPL-1.1@, Reciprocal Public License 1.1-    | RPL_1_5 -- ^ @RPL-1.5@, Reciprocal Public License 1.5-    | RPSL_1_0 -- ^ @RPSL-1.0@, RealNetworks Public Source License v1.0-    | RSA_MD -- ^ @RSA-MD@, RSA Message-Digest License-    | RSCPL -- ^ @RSCPL@, Ricoh Source Code Public License-    | Ruby -- ^ @Ruby@, Ruby License-    | SAX_PD -- ^ @SAX-PD@, Sax Public Domain Notice-    | Saxpath -- ^ @Saxpath@, Saxpath License-    | SCEA -- ^ @SCEA@, SCEA Shared Source License-    | Sendmail_8_23 -- ^ @Sendmail-8.23@, Sendmail License 8.23, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | Sendmail -- ^ @Sendmail@, Sendmail License-    | SGI_B_1_0 -- ^ @SGI-B-1.0@, SGI Free Software License B v1.0-    | SGI_B_1_1 -- ^ @SGI-B-1.1@, SGI Free Software License B v1.1-    | SGI_B_2_0 -- ^ @SGI-B-2.0@, SGI Free Software License B v2.0-    | SHL_0_51 -- ^ @SHL-0.51@, Solderpad Hardware License, Version 0.51, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | SHL_0_5 -- ^ @SHL-0.5@, Solderpad Hardware License v0.5, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | SimPL_2_0 -- ^ @SimPL-2.0@, Simple Public License 2.0-    | SISSL_1_2 -- ^ @SISSL-1.2@, Sun Industry Standards Source License v1.2-    | SISSL -- ^ @SISSL@, Sun Industry Standards Source License v1.1-    | Sleepycat -- ^ @Sleepycat@, Sleepycat License-    | SMLNJ -- ^ @SMLNJ@, Standard ML of New Jersey License-    | SMPPL -- ^ @SMPPL@, Secure Messaging Protocol Public License-    | SNIA -- ^ @SNIA@, SNIA Public License 1.1-    | Spencer_86 -- ^ @Spencer-86@, Spencer License 86-    | Spencer_94 -- ^ @Spencer-94@, Spencer License 94-    | Spencer_99 -- ^ @Spencer-99@, Spencer License 99-    | SPL_1_0 -- ^ @SPL-1.0@, Sun Public License v1.0-    | SSH_OpenSSH -- ^ @SSH-OpenSSH@, SSH OpenSSH license, SPDX License List 3.9, SPDX License List 3.10-    | SSH_short -- ^ @SSH-short@, SSH short notice, SPDX License List 3.9, SPDX License List 3.10-    | SSPL_1_0 -- ^ @SSPL-1.0@, Server Side Public License, v 1, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | SugarCRM_1_1_3 -- ^ @SugarCRM-1.1.3@, SugarCRM Public License v1.1.3-    | SWL -- ^ @SWL@, Scheme Widget Library (SWL) Software License Agreement-    | TAPR_OHL_1_0 -- ^ @TAPR-OHL-1.0@, TAPR Open Hardware License v1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | TCL -- ^ @TCL@, TCL/TK License-    | TCP_wrappers -- ^ @TCP-wrappers@, TCP Wrappers License-    | TMate -- ^ @TMate@, TMate Open Source License-    | TORQUE_1_1 -- ^ @TORQUE-1.1@, TORQUE v2.5+ Software License v1.1-    | TOSL -- ^ @TOSL@, Trusster Open Source License-    | TU_Berlin_1_0 -- ^ @TU-Berlin-1.0@, Technische Universitaet Berlin License 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | TU_Berlin_2_0 -- ^ @TU-Berlin-2.0@, Technische Universitaet Berlin License 2.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10-    | UCL_1_0 -- ^ @UCL-1.0@, Upstream Compatibility License v1.0, SPDX License List 3.9, SPDX License List 3.10-    | Unicode_DFS_2015 -- ^ @Unicode-DFS-2015@, Unicode License Agreement - Data Files and Software (2015)-    | Unicode_DFS_2016 -- ^ @Unicode-DFS-2016@, Unicode License Agreement - Data Files and Software (2016)-    | Unicode_TOU -- ^ @Unicode-TOU@, Unicode Terms of Use-    | Unlicense -- ^ @Unlicense@, The Unlicense-    | UPL_1_0 -- ^ @UPL-1.0@, Universal Permissive License v1.0-    | Vim -- ^ @Vim@, Vim License-    | VOSTROM -- ^ @VOSTROM@, VOSTROM Public License for Open Source-    | VSL_1_0 -- ^ @VSL-1.0@, Vovida Software License v1.0-    | W3C_19980720 -- ^ @W3C-19980720@, W3C Software Notice and License (1998-07-20)-    | W3C_20150513 -- ^ @W3C-20150513@, W3C Software Notice and Document License (2015-05-13)-    | W3C -- ^ @W3C@, W3C Software Notice and License (2002-12-31)-    | Watcom_1_0 -- ^ @Watcom-1.0@, Sybase Open Watcom Public License 1.0-    | Wsuipa -- ^ @Wsuipa@, Wsuipa License-    | WTFPL -- ^ @WTFPL@, Do What The F*ck You Want To Public License-    | X11 -- ^ @X11@, X11 License-    | Xerox -- ^ @Xerox@, Xerox License-    | XFree86_1_1 -- ^ @XFree86-1.1@, XFree86 License 1.1-    | Xinetd -- ^ @xinetd@, xinetd License-    | Xnet -- ^ @Xnet@, X.Net License-    | Xpp -- ^ @xpp@, XPP License-    | XSkat -- ^ @XSkat@, XSkat License-    | YPL_1_0 -- ^ @YPL-1.0@, Yahoo! Public License v1.0-    | YPL_1_1 -- ^ @YPL-1.1@, Yahoo! Public License v1.1-    | Zed -- ^ @Zed@, Zed License-    | Zend_2_0 -- ^ @Zend-2.0@, Zend License v2.0-    | Zimbra_1_3 -- ^ @Zimbra-1.3@, Zimbra Public License v1.3-    | Zimbra_1_4 -- ^ @Zimbra-1.4@, Zimbra Public License v1.4-    | Zlib_acknowledgement -- ^ @zlib-acknowledgement@, zlib/libpng License with Acknowledgement-    | Zlib -- ^ @Zlib@, zlib License-    | ZPL_1_1 -- ^ @ZPL-1.1@, Zope Public License 1.1-    | ZPL_2_0 -- ^ @ZPL-2.0@, Zope Public License 2.0-    | ZPL_2_1 -- ^ @ZPL-2.1@, Zope Public License 2.1-  deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data, Generic)--instance Binary LicenseId where-    -- Word16 is encoded in big endianess-    -- https://github.com/kolmodin/binary/blob/master/src/Data/Binary/Class.hs#L220-LL227-    put = Binary.putWord16be . fromIntegral . fromEnum-    get = do-        i <- Binary.getWord16be-        if i > fromIntegral (fromEnum (maxBound :: LicenseId))-        then fail "Too large LicenseId tag"-        else return (toEnum (fromIntegral i))---- note: remember to bump version each time the definition changes-instance Structured LicenseId where-    structure p = set typeVersion 306 $ nominalStructure p--instance Pretty LicenseId where-    pretty = Disp.text . licenseId---- |--- >>> eitherParsec "BSD-3-Clause" :: Either String LicenseId--- Right BSD_3_Clause------ >>> eitherParsec "BSD3" :: Either String LicenseId--- Left "...Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?"----instance Parsec LicenseId where-    parsec = do-        n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.'-        v <- askCabalSpecVersion-        maybe (fail $ "Unknown SPDX license identifier: '" ++  n ++ "' " ++ licenseIdMigrationMessage n) return $-            mkLicenseId (cabalSpecVersionToSPDXListVersion v) n--instance NFData LicenseId where-    rnf l = l `seq` ()---- | Help message for migrating from non-SPDX license identifiers.------ Old 'License' is almost SPDX, except for 'BSD2', 'BSD3'. This function--- suggests SPDX variant:------ >>> licenseIdMigrationMessage "BSD3"--- "Do you mean BSD-3-Clause?"------ Also 'OtherLicense', 'AllRightsReserved', and 'PublicDomain' aren't--- valid SPDX identifiers------ >>> traverse_ (print . licenseIdMigrationMessage) [ "OtherLicense", "AllRightsReserved", "PublicDomain" ]--- "SPDX license list contains plenty of licenses. See https://spdx.org/licenses/. Also they can be combined into complex expressions with AND and OR."--- "You can use NONE as a value of license field."--- "Public Domain is a complex matter. See https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files. Consider using a proper license."------ SPDX License list version 3.0 introduced "-only" and "-or-later" variants for GNU family of licenses.--- See <https://spdx.org/news/news/2018/01/license-list-30-released>--- >>> licenseIdMigrationMessage "GPL-2.0"--- "SPDX license list 3.0 deprecated suffixless variants of GNU family of licenses. Use GPL-2.0-only or GPL-2.0-or-later."------ For other common licenses their old license format coincides with the SPDX identifiers:------ >>> traverse eitherParsec ["GPL-2.0-only", "GPL-3.0-only", "LGPL-2.1-only", "MIT", "ISC", "MPL-2.0", "Apache-2.0"] :: Either String [LicenseId]--- Right [GPL_2_0_only,GPL_3_0_only,LGPL_2_1_only,MIT,ISC,MPL_2_0,Apache_2_0]----licenseIdMigrationMessage :: String -> String-licenseIdMigrationMessage = go where-    go l | gnuVariant l    = "SPDX license list 3.0 deprecated suffixless variants of GNU family of licenses. Use " ++ l ++ "-only or " ++ l ++ "-or-later."-    go "BSD3"              = "Do you mean BSD-3-Clause?"-    go "BSD2"              = "Do you mean BSD-2-Clause?"-    go "AllRightsReserved" = "You can use NONE as a value of license field."-    go "OtherLicense"      = "SPDX license list contains plenty of licenses. See https://spdx.org/licenses/. Also they can be combined into complex expressions with AND and OR."-    go "PublicDomain"      = "Public Domain is a complex matter. See https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files. Consider using a proper license."--    -- otherwise, we don't know-    go _ = ""--    gnuVariant = flip elem ["GPL-2.0", "GPL-3.0", "LGPL-2.1", "LGPL-3.0", "AGPL-3.0" ]------------------------------------------------------------------------------------ License Data------------------------------------------------------------------------------------ | License SPDX identifier, e.g. @"BSD-3-Clause"@.-licenseId :: LicenseId -> String-licenseId NullBSD = "0BSD"-licenseId AAL = "AAL"-licenseId Abstyles = "Abstyles"-licenseId Adobe_2006 = "Adobe-2006"-licenseId Adobe_Glyph = "Adobe-Glyph"-licenseId ADSL = "ADSL"-licenseId AFL_1_1 = "AFL-1.1"-licenseId AFL_1_2 = "AFL-1.2"-licenseId AFL_2_0 = "AFL-2.0"-licenseId AFL_2_1 = "AFL-2.1"-licenseId AFL_3_0 = "AFL-3.0"-licenseId Afmparse = "Afmparse"-licenseId AGPL_1_0 = "AGPL-1.0"-licenseId AGPL_1_0_only = "AGPL-1.0-only"-licenseId AGPL_1_0_or_later = "AGPL-1.0-or-later"-licenseId AGPL_3_0_only = "AGPL-3.0-only"-licenseId AGPL_3_0_or_later = "AGPL-3.0-or-later"-licenseId Aladdin = "Aladdin"-licenseId AMDPLPA = "AMDPLPA"-licenseId AML = "AML"-licenseId AMPAS = "AMPAS"-licenseId ANTLR_PD = "ANTLR-PD"-licenseId Apache_1_0 = "Apache-1.0"-licenseId Apache_1_1 = "Apache-1.1"-licenseId Apache_2_0 = "Apache-2.0"-licenseId APAFML = "APAFML"-licenseId APL_1_0 = "APL-1.0"-licenseId APSL_1_0 = "APSL-1.0"-licenseId APSL_1_1 = "APSL-1.1"-licenseId APSL_1_2 = "APSL-1.2"-licenseId APSL_2_0 = "APSL-2.0"-licenseId Artistic_1_0_cl8 = "Artistic-1.0-cl8"-licenseId Artistic_1_0_Perl = "Artistic-1.0-Perl"-licenseId Artistic_1_0 = "Artistic-1.0"-licenseId Artistic_2_0 = "Artistic-2.0"-licenseId Bahyph = "Bahyph"-licenseId Barr = "Barr"-licenseId Beerware = "Beerware"-licenseId BitTorrent_1_0 = "BitTorrent-1.0"-licenseId BitTorrent_1_1 = "BitTorrent-1.1"-licenseId Blessing = "blessing"-licenseId BlueOak_1_0_0 = "BlueOak-1.0.0"-licenseId Borceux = "Borceux"-licenseId BSD_1_Clause = "BSD-1-Clause"-licenseId BSD_2_Clause_FreeBSD = "BSD-2-Clause-FreeBSD"-licenseId BSD_2_Clause_NetBSD = "BSD-2-Clause-NetBSD"-licenseId BSD_2_Clause_Patent = "BSD-2-Clause-Patent"-licenseId BSD_2_Clause_Views = "BSD-2-Clause-Views"-licenseId BSD_2_Clause = "BSD-2-Clause"-licenseId BSD_3_Clause_Attribution = "BSD-3-Clause-Attribution"-licenseId BSD_3_Clause_Clear = "BSD-3-Clause-Clear"-licenseId BSD_3_Clause_LBNL = "BSD-3-Clause-LBNL"-licenseId BSD_3_Clause_No_Nuclear_License_2014 = "BSD-3-Clause-No-Nuclear-License-2014"-licenseId BSD_3_Clause_No_Nuclear_License = "BSD-3-Clause-No-Nuclear-License"-licenseId BSD_3_Clause_No_Nuclear_Warranty = "BSD-3-Clause-No-Nuclear-Warranty"-licenseId BSD_3_Clause_Open_MPI = "BSD-3-Clause-Open-MPI"-licenseId BSD_3_Clause = "BSD-3-Clause"-licenseId BSD_4_Clause_UC = "BSD-4-Clause-UC"-licenseId BSD_4_Clause = "BSD-4-Clause"-licenseId BSD_Protection = "BSD-Protection"-licenseId BSD_Source_Code = "BSD-Source-Code"-licenseId BSL_1_0 = "BSL-1.0"-licenseId Bzip2_1_0_5 = "bzip2-1.0.5"-licenseId Bzip2_1_0_6 = "bzip2-1.0.6"-licenseId CAL_1_0_Combined_Work_Exception = "CAL-1.0-Combined-Work-Exception"-licenseId CAL_1_0 = "CAL-1.0"-licenseId Caldera = "Caldera"-licenseId CATOSL_1_1 = "CATOSL-1.1"-licenseId CC_BY_1_0 = "CC-BY-1.0"-licenseId CC_BY_2_0 = "CC-BY-2.0"-licenseId CC_BY_2_5 = "CC-BY-2.5"-licenseId CC_BY_3_0_AT = "CC-BY-3.0-AT"-licenseId CC_BY_3_0 = "CC-BY-3.0"-licenseId CC_BY_4_0 = "CC-BY-4.0"-licenseId CC_BY_NC_1_0 = "CC-BY-NC-1.0"-licenseId CC_BY_NC_2_0 = "CC-BY-NC-2.0"-licenseId CC_BY_NC_2_5 = "CC-BY-NC-2.5"-licenseId CC_BY_NC_3_0 = "CC-BY-NC-3.0"-licenseId CC_BY_NC_4_0 = "CC-BY-NC-4.0"-licenseId CC_BY_NC_ND_1_0 = "CC-BY-NC-ND-1.0"-licenseId CC_BY_NC_ND_2_0 = "CC-BY-NC-ND-2.0"-licenseId CC_BY_NC_ND_2_5 = "CC-BY-NC-ND-2.5"-licenseId CC_BY_NC_ND_3_0_IGO = "CC-BY-NC-ND-3.0-IGO"-licenseId CC_BY_NC_ND_3_0 = "CC-BY-NC-ND-3.0"-licenseId CC_BY_NC_ND_4_0 = "CC-BY-NC-ND-4.0"-licenseId CC_BY_NC_SA_1_0 = "CC-BY-NC-SA-1.0"-licenseId CC_BY_NC_SA_2_0 = "CC-BY-NC-SA-2.0"-licenseId CC_BY_NC_SA_2_5 = "CC-BY-NC-SA-2.5"-licenseId CC_BY_NC_SA_3_0 = "CC-BY-NC-SA-3.0"-licenseId CC_BY_NC_SA_4_0 = "CC-BY-NC-SA-4.0"-licenseId CC_BY_ND_1_0 = "CC-BY-ND-1.0"-licenseId CC_BY_ND_2_0 = "CC-BY-ND-2.0"-licenseId CC_BY_ND_2_5 = "CC-BY-ND-2.5"-licenseId CC_BY_ND_3_0 = "CC-BY-ND-3.0"-licenseId CC_BY_ND_4_0 = "CC-BY-ND-4.0"-licenseId CC_BY_SA_1_0 = "CC-BY-SA-1.0"-licenseId CC_BY_SA_2_0 = "CC-BY-SA-2.0"-licenseId CC_BY_SA_2_5 = "CC-BY-SA-2.5"-licenseId CC_BY_SA_3_0_AT = "CC-BY-SA-3.0-AT"-licenseId CC_BY_SA_3_0 = "CC-BY-SA-3.0"-licenseId CC_BY_SA_4_0 = "CC-BY-SA-4.0"-licenseId CC_PDDC = "CC-PDDC"-licenseId CC0_1_0 = "CC0-1.0"-licenseId CDDL_1_0 = "CDDL-1.0"-licenseId CDDL_1_1 = "CDDL-1.1"-licenseId CDLA_Permissive_1_0 = "CDLA-Permissive-1.0"-licenseId CDLA_Sharing_1_0 = "CDLA-Sharing-1.0"-licenseId CECILL_1_0 = "CECILL-1.0"-licenseId CECILL_1_1 = "CECILL-1.1"-licenseId CECILL_2_0 = "CECILL-2.0"-licenseId CECILL_2_1 = "CECILL-2.1"-licenseId CECILL_B = "CECILL-B"-licenseId CECILL_C = "CECILL-C"-licenseId CERN_OHL_1_1 = "CERN-OHL-1.1"-licenseId CERN_OHL_1_2 = "CERN-OHL-1.2"-licenseId CERN_OHL_P_2_0 = "CERN-OHL-P-2.0"-licenseId CERN_OHL_S_2_0 = "CERN-OHL-S-2.0"-licenseId CERN_OHL_W_2_0 = "CERN-OHL-W-2.0"-licenseId ClArtistic = "ClArtistic"-licenseId CNRI_Jython = "CNRI-Jython"-licenseId CNRI_Python_GPL_Compatible = "CNRI-Python-GPL-Compatible"-licenseId CNRI_Python = "CNRI-Python"-licenseId Condor_1_1 = "Condor-1.1"-licenseId Copyleft_next_0_3_0 = "copyleft-next-0.3.0"-licenseId Copyleft_next_0_3_1 = "copyleft-next-0.3.1"-licenseId CPAL_1_0 = "CPAL-1.0"-licenseId CPL_1_0 = "CPL-1.0"-licenseId CPOL_1_02 = "CPOL-1.02"-licenseId Crossword = "Crossword"-licenseId CrystalStacker = "CrystalStacker"-licenseId CUA_OPL_1_0 = "CUA-OPL-1.0"-licenseId Cube = "Cube"-licenseId Curl = "curl"-licenseId D_FSL_1_0 = "D-FSL-1.0"-licenseId Diffmark = "diffmark"-licenseId DOC = "DOC"-licenseId Dotseqn = "Dotseqn"-licenseId DSDP = "DSDP"-licenseId Dvipdfm = "dvipdfm"-licenseId ECL_1_0 = "ECL-1.0"-licenseId ECL_2_0 = "ECL-2.0"-licenseId EFL_1_0 = "EFL-1.0"-licenseId EFL_2_0 = "EFL-2.0"-licenseId EGenix = "eGenix"-licenseId Entessa = "Entessa"-licenseId EPICS = "EPICS"-licenseId EPL_1_0 = "EPL-1.0"-licenseId EPL_2_0 = "EPL-2.0"-licenseId ErlPL_1_1 = "ErlPL-1.1"-licenseId Etalab_2_0 = "etalab-2.0"-licenseId EUDatagrid = "EUDatagrid"-licenseId EUPL_1_0 = "EUPL-1.0"-licenseId EUPL_1_1 = "EUPL-1.1"-licenseId EUPL_1_2 = "EUPL-1.2"-licenseId Eurosym = "Eurosym"-licenseId Fair = "Fair"-licenseId Frameworx_1_0 = "Frameworx-1.0"-licenseId FreeImage = "FreeImage"-licenseId FSFAP = "FSFAP"-licenseId FSFULLR = "FSFULLR"-licenseId FSFUL = "FSFUL"-licenseId FTL = "FTL"-licenseId GFDL_1_1_invariants_only = "GFDL-1.1-invariants-only"-licenseId GFDL_1_1_invariants_or_later = "GFDL-1.1-invariants-or-later"-licenseId GFDL_1_1_no_invariants_only = "GFDL-1.1-no-invariants-only"-licenseId GFDL_1_1_no_invariants_or_later = "GFDL-1.1-no-invariants-or-later"-licenseId GFDL_1_1_only = "GFDL-1.1-only"-licenseId GFDL_1_1_or_later = "GFDL-1.1-or-later"-licenseId GFDL_1_2_invariants_only = "GFDL-1.2-invariants-only"-licenseId GFDL_1_2_invariants_or_later = "GFDL-1.2-invariants-or-later"-licenseId GFDL_1_2_no_invariants_only = "GFDL-1.2-no-invariants-only"-licenseId GFDL_1_2_no_invariants_or_later = "GFDL-1.2-no-invariants-or-later"-licenseId GFDL_1_2_only = "GFDL-1.2-only"-licenseId GFDL_1_2_or_later = "GFDL-1.2-or-later"-licenseId GFDL_1_3_invariants_only = "GFDL-1.3-invariants-only"-licenseId GFDL_1_3_invariants_or_later = "GFDL-1.3-invariants-or-later"-licenseId GFDL_1_3_no_invariants_only = "GFDL-1.3-no-invariants-only"-licenseId GFDL_1_3_no_invariants_or_later = "GFDL-1.3-no-invariants-or-later"-licenseId GFDL_1_3_only = "GFDL-1.3-only"-licenseId GFDL_1_3_or_later = "GFDL-1.3-or-later"-licenseId Giftware = "Giftware"-licenseId GL2PS = "GL2PS"-licenseId Glide = "Glide"-licenseId Glulxe = "Glulxe"-licenseId GLWTPL = "GLWTPL"-licenseId Gnuplot = "gnuplot"-licenseId GPL_1_0_only = "GPL-1.0-only"-licenseId GPL_1_0_or_later = "GPL-1.0-or-later"-licenseId GPL_2_0_only = "GPL-2.0-only"-licenseId GPL_2_0_or_later = "GPL-2.0-or-later"-licenseId GPL_3_0_only = "GPL-3.0-only"-licenseId GPL_3_0_or_later = "GPL-3.0-or-later"-licenseId GSOAP_1_3b = "gSOAP-1.3b"-licenseId HaskellReport = "HaskellReport"-licenseId Hippocratic_2_1 = "Hippocratic-2.1"-licenseId HPND_sell_variant = "HPND-sell-variant"-licenseId HPND = "HPND"-licenseId IBM_pibs = "IBM-pibs"-licenseId ICU = "ICU"-licenseId IJG = "IJG"-licenseId ImageMagick = "ImageMagick"-licenseId IMatix = "iMatix"-licenseId Imlib2 = "Imlib2"-licenseId Info_ZIP = "Info-ZIP"-licenseId Intel_ACPI = "Intel-ACPI"-licenseId Intel = "Intel"-licenseId Interbase_1_0 = "Interbase-1.0"-licenseId IPA = "IPA"-licenseId IPL_1_0 = "IPL-1.0"-licenseId ISC = "ISC"-licenseId JasPer_2_0 = "JasPer-2.0"-licenseId JPNIC = "JPNIC"-licenseId JSON = "JSON"-licenseId LAL_1_2 = "LAL-1.2"-licenseId LAL_1_3 = "LAL-1.3"-licenseId Latex2e = "Latex2e"-licenseId Leptonica = "Leptonica"-licenseId LGPL_2_0_only = "LGPL-2.0-only"-licenseId LGPL_2_0_or_later = "LGPL-2.0-or-later"-licenseId LGPL_2_1_only = "LGPL-2.1-only"-licenseId LGPL_2_1_or_later = "LGPL-2.1-or-later"-licenseId LGPL_3_0_only = "LGPL-3.0-only"-licenseId LGPL_3_0_or_later = "LGPL-3.0-or-later"-licenseId LGPLLR = "LGPLLR"-licenseId Libpng_2_0 = "libpng-2.0"-licenseId Libpng = "Libpng"-licenseId Libselinux_1_0 = "libselinux-1.0"-licenseId Libtiff = "libtiff"-licenseId LiLiQ_P_1_1 = "LiLiQ-P-1.1"-licenseId LiLiQ_R_1_1 = "LiLiQ-R-1.1"-licenseId LiLiQ_Rplus_1_1 = "LiLiQ-Rplus-1.1"-licenseId Linux_OpenIB = "Linux-OpenIB"-licenseId LPL_1_02 = "LPL-1.02"-licenseId LPL_1_0 = "LPL-1.0"-licenseId LPPL_1_0 = "LPPL-1.0"-licenseId LPPL_1_1 = "LPPL-1.1"-licenseId LPPL_1_2 = "LPPL-1.2"-licenseId LPPL_1_3a = "LPPL-1.3a"-licenseId LPPL_1_3c = "LPPL-1.3c"-licenseId MakeIndex = "MakeIndex"-licenseId MirOS = "MirOS"-licenseId MIT_0 = "MIT-0"-licenseId MIT_advertising = "MIT-advertising"-licenseId MIT_CMU = "MIT-CMU"-licenseId MIT_enna = "MIT-enna"-licenseId MIT_feh = "MIT-feh"-licenseId MITNFA = "MITNFA"-licenseId MIT = "MIT"-licenseId Motosoto = "Motosoto"-licenseId Mpich2 = "mpich2"-licenseId MPL_1_0 = "MPL-1.0"-licenseId MPL_1_1 = "MPL-1.1"-licenseId MPL_2_0_no_copyleft_exception = "MPL-2.0-no-copyleft-exception"-licenseId MPL_2_0 = "MPL-2.0"-licenseId MS_PL = "MS-PL"-licenseId MS_RL = "MS-RL"-licenseId MTLL = "MTLL"-licenseId MulanPSL_1_0 = "MulanPSL-1.0"-licenseId MulanPSL_2_0 = "MulanPSL-2.0"-licenseId Multics = "Multics"-licenseId Mup = "Mup"-licenseId NASA_1_3 = "NASA-1.3"-licenseId Naumen = "Naumen"-licenseId NBPL_1_0 = "NBPL-1.0"-licenseId NCGL_UK_2_0 = "NCGL-UK-2.0"-licenseId NCSA = "NCSA"-licenseId Net_SNMP = "Net-SNMP"-licenseId NetCDF = "NetCDF"-licenseId Newsletr = "Newsletr"-licenseId NGPL = "NGPL"-licenseId NIST_PD_fallback = "NIST-PD-fallback"-licenseId NIST_PD = "NIST-PD"-licenseId NLOD_1_0 = "NLOD-1.0"-licenseId NLPL = "NLPL"-licenseId Nokia = "Nokia"-licenseId NOSL = "NOSL"-licenseId Noweb = "Noweb"-licenseId NPL_1_0 = "NPL-1.0"-licenseId NPL_1_1 = "NPL-1.1"-licenseId NPOSL_3_0 = "NPOSL-3.0"-licenseId NRL = "NRL"-licenseId NTP_0 = "NTP-0"-licenseId NTP = "NTP"-licenseId O_UDA_1_0 = "O-UDA-1.0"-licenseId OCCT_PL = "OCCT-PL"-licenseId OCLC_2_0 = "OCLC-2.0"-licenseId ODbL_1_0 = "ODbL-1.0"-licenseId ODC_By_1_0 = "ODC-By-1.0"-licenseId OFL_1_0_no_RFN = "OFL-1.0-no-RFN"-licenseId OFL_1_0_RFN = "OFL-1.0-RFN"-licenseId OFL_1_0 = "OFL-1.0"-licenseId OFL_1_1_no_RFN = "OFL-1.1-no-RFN"-licenseId OFL_1_1_RFN = "OFL-1.1-RFN"-licenseId OFL_1_1 = "OFL-1.1"-licenseId OGC_1_0 = "OGC-1.0"-licenseId OGL_Canada_2_0 = "OGL-Canada-2.0"-licenseId OGL_UK_1_0 = "OGL-UK-1.0"-licenseId OGL_UK_2_0 = "OGL-UK-2.0"-licenseId OGL_UK_3_0 = "OGL-UK-3.0"-licenseId OGTSL = "OGTSL"-licenseId OLDAP_1_1 = "OLDAP-1.1"-licenseId OLDAP_1_2 = "OLDAP-1.2"-licenseId OLDAP_1_3 = "OLDAP-1.3"-licenseId OLDAP_1_4 = "OLDAP-1.4"-licenseId OLDAP_2_0_1 = "OLDAP-2.0.1"-licenseId OLDAP_2_0 = "OLDAP-2.0"-licenseId OLDAP_2_1 = "OLDAP-2.1"-licenseId OLDAP_2_2_1 = "OLDAP-2.2.1"-licenseId OLDAP_2_2_2 = "OLDAP-2.2.2"-licenseId OLDAP_2_2 = "OLDAP-2.2"-licenseId OLDAP_2_3 = "OLDAP-2.3"-licenseId OLDAP_2_4 = "OLDAP-2.4"-licenseId OLDAP_2_5 = "OLDAP-2.5"-licenseId OLDAP_2_6 = "OLDAP-2.6"-licenseId OLDAP_2_7 = "OLDAP-2.7"-licenseId OLDAP_2_8 = "OLDAP-2.8"-licenseId OML = "OML"-licenseId OpenSSL = "OpenSSL"-licenseId OPL_1_0 = "OPL-1.0"-licenseId OSET_PL_2_1 = "OSET-PL-2.1"-licenseId OSL_1_0 = "OSL-1.0"-licenseId OSL_1_1 = "OSL-1.1"-licenseId OSL_2_0 = "OSL-2.0"-licenseId OSL_2_1 = "OSL-2.1"-licenseId OSL_3_0 = "OSL-3.0"-licenseId Parity_6_0_0 = "Parity-6.0.0"-licenseId Parity_7_0_0 = "Parity-7.0.0"-licenseId PDDL_1_0 = "PDDL-1.0"-licenseId PHP_3_01 = "PHP-3.01"-licenseId PHP_3_0 = "PHP-3.0"-licenseId Plexus = "Plexus"-licenseId PolyForm_Noncommercial_1_0_0 = "PolyForm-Noncommercial-1.0.0"-licenseId PolyForm_Small_Business_1_0_0 = "PolyForm-Small-Business-1.0.0"-licenseId PostgreSQL = "PostgreSQL"-licenseId PSF_2_0 = "PSF-2.0"-licenseId Psfrag = "psfrag"-licenseId Psutils = "psutils"-licenseId Python_2_0 = "Python-2.0"-licenseId Qhull = "Qhull"-licenseId QPL_1_0 = "QPL-1.0"-licenseId Rdisc = "Rdisc"-licenseId RHeCos_1_1 = "RHeCos-1.1"-licenseId RPL_1_1 = "RPL-1.1"-licenseId RPL_1_5 = "RPL-1.5"-licenseId RPSL_1_0 = "RPSL-1.0"-licenseId RSA_MD = "RSA-MD"-licenseId RSCPL = "RSCPL"-licenseId Ruby = "Ruby"-licenseId SAX_PD = "SAX-PD"-licenseId Saxpath = "Saxpath"-licenseId SCEA = "SCEA"-licenseId Sendmail_8_23 = "Sendmail-8.23"-licenseId Sendmail = "Sendmail"-licenseId SGI_B_1_0 = "SGI-B-1.0"-licenseId SGI_B_1_1 = "SGI-B-1.1"-licenseId SGI_B_2_0 = "SGI-B-2.0"-licenseId SHL_0_51 = "SHL-0.51"-licenseId SHL_0_5 = "SHL-0.5"-licenseId SimPL_2_0 = "SimPL-2.0"-licenseId SISSL_1_2 = "SISSL-1.2"-licenseId SISSL = "SISSL"-licenseId Sleepycat = "Sleepycat"-licenseId SMLNJ = "SMLNJ"-licenseId SMPPL = "SMPPL"-licenseId SNIA = "SNIA"-licenseId Spencer_86 = "Spencer-86"-licenseId Spencer_94 = "Spencer-94"-licenseId Spencer_99 = "Spencer-99"-licenseId SPL_1_0 = "SPL-1.0"-licenseId SSH_OpenSSH = "SSH-OpenSSH"-licenseId SSH_short = "SSH-short"-licenseId SSPL_1_0 = "SSPL-1.0"-licenseId SugarCRM_1_1_3 = "SugarCRM-1.1.3"-licenseId SWL = "SWL"-licenseId TAPR_OHL_1_0 = "TAPR-OHL-1.0"-licenseId TCL = "TCL"-licenseId TCP_wrappers = "TCP-wrappers"-licenseId TMate = "TMate"-licenseId TORQUE_1_1 = "TORQUE-1.1"-licenseId TOSL = "TOSL"-licenseId TU_Berlin_1_0 = "TU-Berlin-1.0"-licenseId TU_Berlin_2_0 = "TU-Berlin-2.0"-licenseId UCL_1_0 = "UCL-1.0"-licenseId Unicode_DFS_2015 = "Unicode-DFS-2015"-licenseId Unicode_DFS_2016 = "Unicode-DFS-2016"-licenseId Unicode_TOU = "Unicode-TOU"-licenseId Unlicense = "Unlicense"-licenseId UPL_1_0 = "UPL-1.0"-licenseId Vim = "Vim"-licenseId VOSTROM = "VOSTROM"-licenseId VSL_1_0 = "VSL-1.0"-licenseId W3C_19980720 = "W3C-19980720"-licenseId W3C_20150513 = "W3C-20150513"-licenseId W3C = "W3C"-licenseId Watcom_1_0 = "Watcom-1.0"-licenseId Wsuipa = "Wsuipa"-licenseId WTFPL = "WTFPL"-licenseId X11 = "X11"-licenseId Xerox = "Xerox"-licenseId XFree86_1_1 = "XFree86-1.1"-licenseId Xinetd = "xinetd"-licenseId Xnet = "Xnet"-licenseId Xpp = "xpp"-licenseId XSkat = "XSkat"-licenseId YPL_1_0 = "YPL-1.0"-licenseId YPL_1_1 = "YPL-1.1"-licenseId Zed = "Zed"-licenseId Zend_2_0 = "Zend-2.0"-licenseId Zimbra_1_3 = "Zimbra-1.3"-licenseId Zimbra_1_4 = "Zimbra-1.4"-licenseId Zlib_acknowledgement = "zlib-acknowledgement"-licenseId Zlib = "Zlib"-licenseId ZPL_1_1 = "ZPL-1.1"-licenseId ZPL_2_0 = "ZPL-2.0"-licenseId ZPL_2_1 = "ZPL-2.1"---- | License name, e.g. @"GNU General Public License v2.0 only"@-licenseName :: LicenseId -> String-licenseName NullBSD = "BSD Zero Clause License"-licenseName AAL = "Attribution Assurance License"-licenseName Abstyles = "Abstyles License"-licenseName Adobe_2006 = "Adobe Systems Incorporated Source Code License Agreement"-licenseName Adobe_Glyph = "Adobe Glyph List License"-licenseName ADSL = "Amazon Digital Services License"-licenseName AFL_1_1 = "Academic Free License v1.1"-licenseName AFL_1_2 = "Academic Free License v1.2"-licenseName AFL_2_0 = "Academic Free License v2.0"-licenseName AFL_2_1 = "Academic Free License v2.1"-licenseName AFL_3_0 = "Academic Free License v3.0"-licenseName Afmparse = "Afmparse License"-licenseName AGPL_1_0 = "Affero General Public License v1.0"-licenseName AGPL_1_0_only = "Affero General Public License v1.0 only"-licenseName AGPL_1_0_or_later = "Affero General Public License v1.0 or later"-licenseName AGPL_3_0_only = "GNU Affero General Public License v3.0 only"-licenseName AGPL_3_0_or_later = "GNU Affero General Public License v3.0 or later"-licenseName Aladdin = "Aladdin Free Public License"-licenseName AMDPLPA = "AMD's plpa_map.c License"-licenseName AML = "Apple MIT License"-licenseName AMPAS = "Academy of Motion Picture Arts and Sciences BSD"-licenseName ANTLR_PD = "ANTLR Software Rights Notice"-licenseName Apache_1_0 = "Apache License 1.0"-licenseName Apache_1_1 = "Apache License 1.1"-licenseName Apache_2_0 = "Apache License 2.0"-licenseName APAFML = "Adobe Postscript AFM License"-licenseName APL_1_0 = "Adaptive Public License 1.0"-licenseName APSL_1_0 = "Apple Public Source License 1.0"-licenseName APSL_1_1 = "Apple Public Source License 1.1"-licenseName APSL_1_2 = "Apple Public Source License 1.2"-licenseName APSL_2_0 = "Apple Public Source License 2.0"-licenseName Artistic_1_0_cl8 = "Artistic License 1.0 w/clause 8"-licenseName Artistic_1_0_Perl = "Artistic License 1.0 (Perl)"-licenseName Artistic_1_0 = "Artistic License 1.0"-licenseName Artistic_2_0 = "Artistic License 2.0"-licenseName Bahyph = "Bahyph License"-licenseName Barr = "Barr License"-licenseName Beerware = "Beerware License"-licenseName BitTorrent_1_0 = "BitTorrent Open Source License v1.0"-licenseName BitTorrent_1_1 = "BitTorrent Open Source License v1.1"-licenseName Blessing = "SQLite Blessing"-licenseName BlueOak_1_0_0 = "Blue Oak Model License 1.0.0"-licenseName Borceux = "Borceux license"-licenseName BSD_1_Clause = "BSD 1-Clause License"-licenseName BSD_2_Clause_FreeBSD = "BSD 2-Clause FreeBSD License"-licenseName BSD_2_Clause_NetBSD = "BSD 2-Clause NetBSD License"-licenseName BSD_2_Clause_Patent = "BSD-2-Clause Plus Patent License"-licenseName BSD_2_Clause_Views = "BSD 2-Clause with views sentence"-licenseName BSD_2_Clause = "BSD 2-Clause \"Simplified\" License"-licenseName BSD_3_Clause_Attribution = "BSD with attribution"-licenseName BSD_3_Clause_Clear = "BSD 3-Clause Clear License"-licenseName BSD_3_Clause_LBNL = "Lawrence Berkeley National Labs BSD variant license"-licenseName BSD_3_Clause_No_Nuclear_License_2014 = "BSD 3-Clause No Nuclear License 2014"-licenseName BSD_3_Clause_No_Nuclear_License = "BSD 3-Clause No Nuclear License"-licenseName BSD_3_Clause_No_Nuclear_Warranty = "BSD 3-Clause No Nuclear Warranty"-licenseName BSD_3_Clause_Open_MPI = "BSD 3-Clause Open MPI variant"-licenseName BSD_3_Clause = "BSD 3-Clause \"New\" or \"Revised\" License"-licenseName BSD_4_Clause_UC = "BSD-4-Clause (University of California-Specific)"-licenseName BSD_4_Clause = "BSD 4-Clause \"Original\" or \"Old\" License"-licenseName BSD_Protection = "BSD Protection License"-licenseName BSD_Source_Code = "BSD Source Code Attribution"-licenseName BSL_1_0 = "Boost Software License 1.0"-licenseName Bzip2_1_0_5 = "bzip2 and libbzip2 License v1.0.5"-licenseName Bzip2_1_0_6 = "bzip2 and libbzip2 License v1.0.6"-licenseName CAL_1_0_Combined_Work_Exception = "Cryptographic Autonomy License 1.0 (Combined Work Exception)"-licenseName CAL_1_0 = "Cryptographic Autonomy License 1.0"-licenseName Caldera = "Caldera License"-licenseName CATOSL_1_1 = "Computer Associates Trusted Open Source License 1.1"-licenseName CC_BY_1_0 = "Creative Commons Attribution 1.0 Generic"-licenseName CC_BY_2_0 = "Creative Commons Attribution 2.0 Generic"-licenseName CC_BY_2_5 = "Creative Commons Attribution 2.5 Generic"-licenseName CC_BY_3_0_AT = "Creative Commons Attribution 3.0 Austria"-licenseName CC_BY_3_0 = "Creative Commons Attribution 3.0 Unported"-licenseName CC_BY_4_0 = "Creative Commons Attribution 4.0 International"-licenseName CC_BY_NC_1_0 = "Creative Commons Attribution Non Commercial 1.0 Generic"-licenseName CC_BY_NC_2_0 = "Creative Commons Attribution Non Commercial 2.0 Generic"-licenseName CC_BY_NC_2_5 = "Creative Commons Attribution Non Commercial 2.5 Generic"-licenseName CC_BY_NC_3_0 = "Creative Commons Attribution Non Commercial 3.0 Unported"-licenseName CC_BY_NC_4_0 = "Creative Commons Attribution Non Commercial 4.0 International"-licenseName CC_BY_NC_ND_1_0 = "Creative Commons Attribution Non Commercial No Derivatives 1.0 Generic"-licenseName CC_BY_NC_ND_2_0 = "Creative Commons Attribution Non Commercial No Derivatives 2.0 Generic"-licenseName CC_BY_NC_ND_2_5 = "Creative Commons Attribution Non Commercial No Derivatives 2.5 Generic"-licenseName CC_BY_NC_ND_3_0_IGO = "Creative Commons Attribution Non Commercial No Derivatives 3.0 IGO"-licenseName CC_BY_NC_ND_3_0 = "Creative Commons Attribution Non Commercial No Derivatives 3.0 Unported"-licenseName CC_BY_NC_ND_4_0 = "Creative Commons Attribution Non Commercial No Derivatives 4.0 International"-licenseName CC_BY_NC_SA_1_0 = "Creative Commons Attribution Non Commercial Share Alike 1.0 Generic"-licenseName CC_BY_NC_SA_2_0 = "Creative Commons Attribution Non Commercial Share Alike 2.0 Generic"-licenseName CC_BY_NC_SA_2_5 = "Creative Commons Attribution Non Commercial Share Alike 2.5 Generic"-licenseName CC_BY_NC_SA_3_0 = "Creative Commons Attribution Non Commercial Share Alike 3.0 Unported"-licenseName CC_BY_NC_SA_4_0 = "Creative Commons Attribution Non Commercial Share Alike 4.0 International"-licenseName CC_BY_ND_1_0 = "Creative Commons Attribution No Derivatives 1.0 Generic"-licenseName CC_BY_ND_2_0 = "Creative Commons Attribution No Derivatives 2.0 Generic"-licenseName CC_BY_ND_2_5 = "Creative Commons Attribution No Derivatives 2.5 Generic"-licenseName CC_BY_ND_3_0 = "Creative Commons Attribution No Derivatives 3.0 Unported"-licenseName CC_BY_ND_4_0 = "Creative Commons Attribution No Derivatives 4.0 International"-licenseName CC_BY_SA_1_0 = "Creative Commons Attribution Share Alike 1.0 Generic"-licenseName CC_BY_SA_2_0 = "Creative Commons Attribution Share Alike 2.0 Generic"-licenseName CC_BY_SA_2_5 = "Creative Commons Attribution Share Alike 2.5 Generic"-licenseName CC_BY_SA_3_0_AT = "Creative Commons Attribution-Share Alike 3.0 Austria"-licenseName CC_BY_SA_3_0 = "Creative Commons Attribution Share Alike 3.0 Unported"-licenseName CC_BY_SA_4_0 = "Creative Commons Attribution Share Alike 4.0 International"-licenseName CC_PDDC = "Creative Commons Public Domain Dedication and Certification"-licenseName CC0_1_0 = "Creative Commons Zero v1.0 Universal"-licenseName CDDL_1_0 = "Common Development and Distribution License 1.0"-licenseName CDDL_1_1 = "Common Development and Distribution License 1.1"-licenseName CDLA_Permissive_1_0 = "Community Data License Agreement Permissive 1.0"-licenseName CDLA_Sharing_1_0 = "Community Data License Agreement Sharing 1.0"-licenseName CECILL_1_0 = "CeCILL Free Software License Agreement v1.0"-licenseName CECILL_1_1 = "CeCILL Free Software License Agreement v1.1"-licenseName CECILL_2_0 = "CeCILL Free Software License Agreement v2.0"-licenseName CECILL_2_1 = "CeCILL Free Software License Agreement v2.1"-licenseName CECILL_B = "CeCILL-B Free Software License Agreement"-licenseName CECILL_C = "CeCILL-C Free Software License Agreement"-licenseName CERN_OHL_1_1 = "CERN Open Hardware Licence v1.1"-licenseName CERN_OHL_1_2 = "CERN Open Hardware Licence v1.2"-licenseName CERN_OHL_P_2_0 = "CERN Open Hardware Licence Version 2 - Permissive"-licenseName CERN_OHL_S_2_0 = "CERN Open Hardware Licence Version 2 - Strongly Reciprocal"-licenseName CERN_OHL_W_2_0 = "CERN Open Hardware Licence Version 2 - Weakly Reciprocal"-licenseName ClArtistic = "Clarified Artistic License"-licenseName CNRI_Jython = "CNRI Jython License"-licenseName CNRI_Python_GPL_Compatible = "CNRI Python Open Source GPL Compatible License Agreement"-licenseName CNRI_Python = "CNRI Python License"-licenseName Condor_1_1 = "Condor Public License v1.1"-licenseName Copyleft_next_0_3_0 = "copyleft-next 0.3.0"-licenseName Copyleft_next_0_3_1 = "copyleft-next 0.3.1"-licenseName CPAL_1_0 = "Common Public Attribution License 1.0"-licenseName CPL_1_0 = "Common Public License 1.0"-licenseName CPOL_1_02 = "Code Project Open License 1.02"-licenseName Crossword = "Crossword License"-licenseName CrystalStacker = "CrystalStacker License"-licenseName CUA_OPL_1_0 = "CUA Office Public License v1.0"-licenseName Cube = "Cube License"-licenseName Curl = "curl License"-licenseName D_FSL_1_0 = "Deutsche Freie Software Lizenz"-licenseName Diffmark = "diffmark license"-licenseName DOC = "DOC License"-licenseName Dotseqn = "Dotseqn License"-licenseName DSDP = "DSDP License"-licenseName Dvipdfm = "dvipdfm License"-licenseName ECL_1_0 = "Educational Community License v1.0"-licenseName ECL_2_0 = "Educational Community License v2.0"-licenseName EFL_1_0 = "Eiffel Forum License v1.0"-licenseName EFL_2_0 = "Eiffel Forum License v2.0"-licenseName EGenix = "eGenix.com Public License 1.1.0"-licenseName Entessa = "Entessa Public License v1.0"-licenseName EPICS = "EPICS Open License"-licenseName EPL_1_0 = "Eclipse Public License 1.0"-licenseName EPL_2_0 = "Eclipse Public License 2.0"-licenseName ErlPL_1_1 = "Erlang Public License v1.1"-licenseName Etalab_2_0 = "Etalab Open License 2.0"-licenseName EUDatagrid = "EU DataGrid Software License"-licenseName EUPL_1_0 = "European Union Public License 1.0"-licenseName EUPL_1_1 = "European Union Public License 1.1"-licenseName EUPL_1_2 = "European Union Public License 1.2"-licenseName Eurosym = "Eurosym License"-licenseName Fair = "Fair License"-licenseName Frameworx_1_0 = "Frameworx Open License 1.0"-licenseName FreeImage = "FreeImage Public License v1.0"-licenseName FSFAP = "FSF All Permissive License"-licenseName FSFULLR = "FSF Unlimited License (with License Retention)"-licenseName FSFUL = "FSF Unlimited License"-licenseName FTL = "Freetype Project License"-licenseName GFDL_1_1_invariants_only = "GNU Free Documentation License v1.1 only - invariants"-licenseName GFDL_1_1_invariants_or_later = "GNU Free Documentation License v1.1 or later - invariants"-licenseName GFDL_1_1_no_invariants_only = "GNU Free Documentation License v1.1 only - no invariants"-licenseName GFDL_1_1_no_invariants_or_later = "GNU Free Documentation License v1.1 or later - no invariants"-licenseName GFDL_1_1_only = "GNU Free Documentation License v1.1 only"-licenseName GFDL_1_1_or_later = "GNU Free Documentation License v1.1 or later"-licenseName GFDL_1_2_invariants_only = "GNU Free Documentation License v1.2 only - invariants"-licenseName GFDL_1_2_invariants_or_later = "GNU Free Documentation License v1.2 or later - invariants"-licenseName GFDL_1_2_no_invariants_only = "GNU Free Documentation License v1.2 only - no invariants"-licenseName GFDL_1_2_no_invariants_or_later = "GNU Free Documentation License v1.2 or later - no invariants"-licenseName GFDL_1_2_only = "GNU Free Documentation License v1.2 only"-licenseName GFDL_1_2_or_later = "GNU Free Documentation License v1.2 or later"-licenseName GFDL_1_3_invariants_only = "GNU Free Documentation License v1.3 only - invariants"-licenseName GFDL_1_3_invariants_or_later = "GNU Free Documentation License v1.3 or later - invariants"-licenseName GFDL_1_3_no_invariants_only = "GNU Free Documentation License v1.3 only - no invariants"-licenseName GFDL_1_3_no_invariants_or_later = "GNU Free Documentation License v1.3 or later - no invariants"-licenseName GFDL_1_3_only = "GNU Free Documentation License v1.3 only"-licenseName GFDL_1_3_or_later = "GNU Free Documentation License v1.3 or later"-licenseName Giftware = "Giftware License"-licenseName GL2PS = "GL2PS License"-licenseName Glide = "3dfx Glide License"-licenseName Glulxe = "Glulxe License"-licenseName GLWTPL = "Good Luck With That Public License"-licenseName Gnuplot = "gnuplot License"-licenseName GPL_1_0_only = "GNU General Public License v1.0 only"-licenseName GPL_1_0_or_later = "GNU General Public License v1.0 or later"-licenseName GPL_2_0_only = "GNU General Public License v2.0 only"-licenseName GPL_2_0_or_later = "GNU General Public License v2.0 or later"-licenseName GPL_3_0_only = "GNU General Public License v3.0 only"-licenseName GPL_3_0_or_later = "GNU General Public License v3.0 or later"-licenseName GSOAP_1_3b = "gSOAP Public License v1.3b"-licenseName HaskellReport = "Haskell Language Report License"-licenseName Hippocratic_2_1 = "Hippocratic License 2.1"-licenseName HPND_sell_variant = "Historical Permission Notice and Disclaimer - sell variant"-licenseName HPND = "Historical Permission Notice and Disclaimer"-licenseName IBM_pibs = "IBM PowerPC Initialization and Boot Software"-licenseName ICU = "ICU License"-licenseName IJG = "Independent JPEG Group License"-licenseName ImageMagick = "ImageMagick License"-licenseName IMatix = "iMatix Standard Function Library Agreement"-licenseName Imlib2 = "Imlib2 License"-licenseName Info_ZIP = "Info-ZIP License"-licenseName Intel_ACPI = "Intel ACPI Software License Agreement"-licenseName Intel = "Intel Open Source License"-licenseName Interbase_1_0 = "Interbase Public License v1.0"-licenseName IPA = "IPA Font License"-licenseName IPL_1_0 = "IBM Public License v1.0"-licenseName ISC = "ISC License"-licenseName JasPer_2_0 = "JasPer License"-licenseName JPNIC = "Japan Network Information Center License"-licenseName JSON = "JSON License"-licenseName LAL_1_2 = "Licence Art Libre 1.2"-licenseName LAL_1_3 = "Licence Art Libre 1.3"-licenseName Latex2e = "Latex2e License"-licenseName Leptonica = "Leptonica License"-licenseName LGPL_2_0_only = "GNU Library General Public License v2 only"-licenseName LGPL_2_0_or_later = "GNU Library General Public License v2 or later"-licenseName LGPL_2_1_only = "GNU Lesser General Public License v2.1 only"-licenseName LGPL_2_1_or_later = "GNU Lesser General Public License v2.1 or later"-licenseName LGPL_3_0_only = "GNU Lesser General Public License v3.0 only"-licenseName LGPL_3_0_or_later = "GNU Lesser General Public License v3.0 or later"-licenseName LGPLLR = "Lesser General Public License For Linguistic Resources"-licenseName Libpng_2_0 = "PNG Reference Library version 2"-licenseName Libpng = "libpng License"-licenseName Libselinux_1_0 = "libselinux public domain notice"-licenseName Libtiff = "libtiff License"-licenseName LiLiQ_P_1_1 = "Licence Libre du Qu\233bec \8211 Permissive version 1.1"-licenseName LiLiQ_R_1_1 = "Licence Libre du Qu\233bec \8211 R\233ciprocit\233 version 1.1"-licenseName LiLiQ_Rplus_1_1 = "Licence Libre du Qu\233bec \8211 R\233ciprocit\233 forte version 1.1"-licenseName Linux_OpenIB = "Linux Kernel Variant of OpenIB.org license"-licenseName LPL_1_02 = "Lucent Public License v1.02"-licenseName LPL_1_0 = "Lucent Public License Version 1.0"-licenseName LPPL_1_0 = "LaTeX Project Public License v1.0"-licenseName LPPL_1_1 = "LaTeX Project Public License v1.1"-licenseName LPPL_1_2 = "LaTeX Project Public License v1.2"-licenseName LPPL_1_3a = "LaTeX Project Public License v1.3a"-licenseName LPPL_1_3c = "LaTeX Project Public License v1.3c"-licenseName MakeIndex = "MakeIndex License"-licenseName MirOS = "The MirOS Licence"-licenseName MIT_0 = "MIT No Attribution"-licenseName MIT_advertising = "Enlightenment License (e16)"-licenseName MIT_CMU = "CMU License"-licenseName MIT_enna = "enna License"-licenseName MIT_feh = "feh License"-licenseName MITNFA = "MIT +no-false-attribs license"-licenseName MIT = "MIT License"-licenseName Motosoto = "Motosoto License"-licenseName Mpich2 = "mpich2 License"-licenseName MPL_1_0 = "Mozilla Public License 1.0"-licenseName MPL_1_1 = "Mozilla Public License 1.1"-licenseName MPL_2_0_no_copyleft_exception = "Mozilla Public License 2.0 (no copyleft exception)"-licenseName MPL_2_0 = "Mozilla Public License 2.0"-licenseName MS_PL = "Microsoft Public License"-licenseName MS_RL = "Microsoft Reciprocal License"-licenseName MTLL = "Matrix Template Library License"-licenseName MulanPSL_1_0 = "Mulan Permissive Software License, Version 1"-licenseName MulanPSL_2_0 = "Mulan Permissive Software License, Version 2"-licenseName Multics = "Multics License"-licenseName Mup = "Mup License"-licenseName NASA_1_3 = "NASA Open Source Agreement 1.3"-licenseName Naumen = "Naumen Public License"-licenseName NBPL_1_0 = "Net Boolean Public License v1"-licenseName NCGL_UK_2_0 = "Non-Commercial Government Licence"-licenseName NCSA = "University of Illinois/NCSA Open Source License"-licenseName Net_SNMP = "Net-SNMP License"-licenseName NetCDF = "NetCDF license"-licenseName Newsletr = "Newsletr License"-licenseName NGPL = "Nethack General Public License"-licenseName NIST_PD_fallback = "NIST Public Domain Notice with license fallback"-licenseName NIST_PD = "NIST Public Domain Notice"-licenseName NLOD_1_0 = "Norwegian Licence for Open Government Data"-licenseName NLPL = "No Limit Public License"-licenseName Nokia = "Nokia Open Source License"-licenseName NOSL = "Netizen Open Source License"-licenseName Noweb = "Noweb License"-licenseName NPL_1_0 = "Netscape Public License v1.0"-licenseName NPL_1_1 = "Netscape Public License v1.1"-licenseName NPOSL_3_0 = "Non-Profit Open Software License 3.0"-licenseName NRL = "NRL License"-licenseName NTP_0 = "NTP No Attribution"-licenseName NTP = "NTP License"-licenseName O_UDA_1_0 = "Open Use of Data Agreement v1.0"-licenseName OCCT_PL = "Open CASCADE Technology Public License"-licenseName OCLC_2_0 = "OCLC Research Public License 2.0"-licenseName ODbL_1_0 = "ODC Open Database License v1.0"-licenseName ODC_By_1_0 = "Open Data Commons Attribution License v1.0"-licenseName OFL_1_0_no_RFN = "SIL Open Font License 1.0 with no Reserved Font Name"-licenseName OFL_1_0_RFN = "SIL Open Font License 1.0 with Reserved Font Name"-licenseName OFL_1_0 = "SIL Open Font License 1.0"-licenseName OFL_1_1_no_RFN = "SIL Open Font License 1.1 with no Reserved Font Name"-licenseName OFL_1_1_RFN = "SIL Open Font License 1.1 with Reserved Font Name"-licenseName OFL_1_1 = "SIL Open Font License 1.1"-licenseName OGC_1_0 = "OGC Software License, Version 1.0"-licenseName OGL_Canada_2_0 = "Open Government Licence - Canada"-licenseName OGL_UK_1_0 = "Open Government Licence v1.0"-licenseName OGL_UK_2_0 = "Open Government Licence v2.0"-licenseName OGL_UK_3_0 = "Open Government Licence v3.0"-licenseName OGTSL = "Open Group Test Suite License"-licenseName OLDAP_1_1 = "Open LDAP Public License v1.1"-licenseName OLDAP_1_2 = "Open LDAP Public License v1.2"-licenseName OLDAP_1_3 = "Open LDAP Public License v1.3"-licenseName OLDAP_1_4 = "Open LDAP Public License v1.4"-licenseName OLDAP_2_0_1 = "Open LDAP Public License v2.0.1"-licenseName OLDAP_2_0 = "Open LDAP Public License v2.0 (or possibly 2.0A and 2.0B)"-licenseName OLDAP_2_1 = "Open LDAP Public License v2.1"-licenseName OLDAP_2_2_1 = "Open LDAP Public License v2.2.1"-licenseName OLDAP_2_2_2 = "Open LDAP Public License 2.2.2"-licenseName OLDAP_2_2 = "Open LDAP Public License v2.2"-licenseName OLDAP_2_3 = "Open LDAP Public License v2.3"-licenseName OLDAP_2_4 = "Open LDAP Public License v2.4"-licenseName OLDAP_2_5 = "Open LDAP Public License v2.5"-licenseName OLDAP_2_6 = "Open LDAP Public License v2.6"-licenseName OLDAP_2_7 = "Open LDAP Public License v2.7"-licenseName OLDAP_2_8 = "Open LDAP Public License v2.8"-licenseName OML = "Open Market License"-licenseName OpenSSL = "OpenSSL License"-licenseName OPL_1_0 = "Open Public License v1.0"-licenseName OSET_PL_2_1 = "OSET Public License version 2.1"-licenseName OSL_1_0 = "Open Software License 1.0"-licenseName OSL_1_1 = "Open Software License 1.1"-licenseName OSL_2_0 = "Open Software License 2.0"-licenseName OSL_2_1 = "Open Software License 2.1"-licenseName OSL_3_0 = "Open Software License 3.0"-licenseName Parity_6_0_0 = "The Parity Public License 6.0.0"-licenseName Parity_7_0_0 = "The Parity Public License 7.0.0"-licenseName PDDL_1_0 = "ODC Public Domain Dedication & License 1.0"-licenseName PHP_3_01 = "PHP License v3.01"-licenseName PHP_3_0 = "PHP License v3.0"-licenseName Plexus = "Plexus Classworlds License"-licenseName PolyForm_Noncommercial_1_0_0 = "PolyForm Noncommercial License 1.0.0"-licenseName PolyForm_Small_Business_1_0_0 = "PolyForm Small Business License 1.0.0"-licenseName PostgreSQL = "PostgreSQL License"-licenseName PSF_2_0 = "Python Software Foundation License 2.0"-licenseName Psfrag = "psfrag License"-licenseName Psutils = "psutils License"-licenseName Python_2_0 = "Python License 2.0"-licenseName Qhull = "Qhull License"-licenseName QPL_1_0 = "Q Public License 1.0"-licenseName Rdisc = "Rdisc License"-licenseName RHeCos_1_1 = "Red Hat eCos Public License v1.1"-licenseName RPL_1_1 = "Reciprocal Public License 1.1"-licenseName RPL_1_5 = "Reciprocal Public License 1.5"-licenseName RPSL_1_0 = "RealNetworks Public Source License v1.0"-licenseName RSA_MD = "RSA Message-Digest License"-licenseName RSCPL = "Ricoh Source Code Public License"-licenseName Ruby = "Ruby License"-licenseName SAX_PD = "Sax Public Domain Notice"-licenseName Saxpath = "Saxpath License"-licenseName SCEA = "SCEA Shared Source License"-licenseName Sendmail_8_23 = "Sendmail License 8.23"-licenseName Sendmail = "Sendmail License"-licenseName SGI_B_1_0 = "SGI Free Software License B v1.0"-licenseName SGI_B_1_1 = "SGI Free Software License B v1.1"-licenseName SGI_B_2_0 = "SGI Free Software License B v2.0"-licenseName SHL_0_51 = "Solderpad Hardware License, Version 0.51"-licenseName SHL_0_5 = "Solderpad Hardware License v0.5"-licenseName SimPL_2_0 = "Simple Public License 2.0"-licenseName SISSL_1_2 = "Sun Industry Standards Source License v1.2"-licenseName SISSL = "Sun Industry Standards Source License v1.1"-licenseName Sleepycat = "Sleepycat License"-licenseName SMLNJ = "Standard ML of New Jersey License"-licenseName SMPPL = "Secure Messaging Protocol Public License"-licenseName SNIA = "SNIA Public License 1.1"-licenseName Spencer_86 = "Spencer License 86"-licenseName Spencer_94 = "Spencer License 94"-licenseName Spencer_99 = "Spencer License 99"-licenseName SPL_1_0 = "Sun Public License v1.0"-licenseName SSH_OpenSSH = "SSH OpenSSH license"-licenseName SSH_short = "SSH short notice"-licenseName SSPL_1_0 = "Server Side Public License, v 1"-licenseName SugarCRM_1_1_3 = "SugarCRM Public License v1.1.3"-licenseName SWL = "Scheme Widget Library (SWL) Software License Agreement"-licenseName TAPR_OHL_1_0 = "TAPR Open Hardware License v1.0"-licenseName TCL = "TCL/TK License"-licenseName TCP_wrappers = "TCP Wrappers License"-licenseName TMate = "TMate Open Source License"-licenseName TORQUE_1_1 = "TORQUE v2.5+ Software License v1.1"-licenseName TOSL = "Trusster Open Source License"-licenseName TU_Berlin_1_0 = "Technische Universitaet Berlin License 1.0"-licenseName TU_Berlin_2_0 = "Technische Universitaet Berlin License 2.0"-licenseName UCL_1_0 = "Upstream Compatibility License v1.0"-licenseName Unicode_DFS_2015 = "Unicode License Agreement - Data Files and Software (2015)"-licenseName Unicode_DFS_2016 = "Unicode License Agreement - Data Files and Software (2016)"-licenseName Unicode_TOU = "Unicode Terms of Use"-licenseName Unlicense = "The Unlicense"-licenseName UPL_1_0 = "Universal Permissive License v1.0"-licenseName Vim = "Vim License"-licenseName VOSTROM = "VOSTROM Public License for Open Source"-licenseName VSL_1_0 = "Vovida Software License v1.0"-licenseName W3C_19980720 = "W3C Software Notice and License (1998-07-20)"-licenseName W3C_20150513 = "W3C Software Notice and Document License (2015-05-13)"-licenseName W3C = "W3C Software Notice and License (2002-12-31)"-licenseName Watcom_1_0 = "Sybase Open Watcom Public License 1.0"-licenseName Wsuipa = "Wsuipa License"-licenseName WTFPL = "Do What The F*ck You Want To Public License"-licenseName X11 = "X11 License"-licenseName Xerox = "Xerox License"-licenseName XFree86_1_1 = "XFree86 License 1.1"-licenseName Xinetd = "xinetd License"-licenseName Xnet = "X.Net License"-licenseName Xpp = "XPP License"-licenseName XSkat = "XSkat License"-licenseName YPL_1_0 = "Yahoo! Public License v1.0"-licenseName YPL_1_1 = "Yahoo! Public License v1.1"-licenseName Zed = "Zed License"-licenseName Zend_2_0 = "Zend License v2.0"-licenseName Zimbra_1_3 = "Zimbra Public License v1.3"-licenseName Zimbra_1_4 = "Zimbra Public License v1.4"-licenseName Zlib_acknowledgement = "zlib/libpng License with Acknowledgement"-licenseName Zlib = "zlib License"-licenseName ZPL_1_1 = "Zope Public License 1.1"-licenseName ZPL_2_0 = "Zope Public License 2.0"-licenseName ZPL_2_1 = "Zope Public License 2.1"---- | Whether the license is approved by Open Source Initiative (OSI).------ See <https://opensource.org/licenses/alphabetical>.-licenseIsOsiApproved :: LicenseId -> Bool-licenseIsOsiApproved NullBSD = True-licenseIsOsiApproved AAL = True-licenseIsOsiApproved AFL_1_1 = True-licenseIsOsiApproved AFL_1_2 = True-licenseIsOsiApproved AFL_2_0 = True-licenseIsOsiApproved AFL_2_1 = True-licenseIsOsiApproved AFL_3_0 = True-licenseIsOsiApproved AGPL_3_0_only = True-licenseIsOsiApproved AGPL_3_0_or_later = True-licenseIsOsiApproved Apache_1_1 = True-licenseIsOsiApproved Apache_2_0 = True-licenseIsOsiApproved APL_1_0 = True-licenseIsOsiApproved APSL_1_0 = True-licenseIsOsiApproved APSL_1_1 = True-licenseIsOsiApproved APSL_1_2 = True-licenseIsOsiApproved APSL_2_0 = True-licenseIsOsiApproved Artistic_1_0_cl8 = True-licenseIsOsiApproved Artistic_1_0_Perl = True-licenseIsOsiApproved Artistic_1_0 = True-licenseIsOsiApproved Artistic_2_0 = True-licenseIsOsiApproved BSD_1_Clause = True-licenseIsOsiApproved BSD_2_Clause_Patent = True-licenseIsOsiApproved BSD_2_Clause = True-licenseIsOsiApproved BSD_3_Clause_LBNL = True-licenseIsOsiApproved BSD_3_Clause = True-licenseIsOsiApproved BSL_1_0 = True-licenseIsOsiApproved CAL_1_0_Combined_Work_Exception = True-licenseIsOsiApproved CAL_1_0 = True-licenseIsOsiApproved CATOSL_1_1 = True-licenseIsOsiApproved CDDL_1_0 = True-licenseIsOsiApproved CECILL_2_1 = True-licenseIsOsiApproved CNRI_Python = True-licenseIsOsiApproved CPAL_1_0 = True-licenseIsOsiApproved CPL_1_0 = True-licenseIsOsiApproved CUA_OPL_1_0 = True-licenseIsOsiApproved ECL_1_0 = True-licenseIsOsiApproved ECL_2_0 = True-licenseIsOsiApproved EFL_1_0 = True-licenseIsOsiApproved EFL_2_0 = True-licenseIsOsiApproved Entessa = True-licenseIsOsiApproved EPL_1_0 = True-licenseIsOsiApproved EPL_2_0 = True-licenseIsOsiApproved EUDatagrid = True-licenseIsOsiApproved EUPL_1_1 = True-licenseIsOsiApproved EUPL_1_2 = True-licenseIsOsiApproved Fair = True-licenseIsOsiApproved Frameworx_1_0 = True-licenseIsOsiApproved GPL_2_0_only = True-licenseIsOsiApproved GPL_2_0_or_later = True-licenseIsOsiApproved GPL_3_0_only = True-licenseIsOsiApproved GPL_3_0_or_later = True-licenseIsOsiApproved HPND = True-licenseIsOsiApproved Intel = True-licenseIsOsiApproved IPA = True-licenseIsOsiApproved IPL_1_0 = True-licenseIsOsiApproved ISC = True-licenseIsOsiApproved LGPL_2_0_only = True-licenseIsOsiApproved LGPL_2_0_or_later = True-licenseIsOsiApproved LGPL_2_1_only = True-licenseIsOsiApproved LGPL_2_1_or_later = True-licenseIsOsiApproved LGPL_3_0_only = True-licenseIsOsiApproved LGPL_3_0_or_later = True-licenseIsOsiApproved LiLiQ_P_1_1 = True-licenseIsOsiApproved LiLiQ_R_1_1 = True-licenseIsOsiApproved LiLiQ_Rplus_1_1 = True-licenseIsOsiApproved LPL_1_02 = True-licenseIsOsiApproved LPL_1_0 = True-licenseIsOsiApproved LPPL_1_3c = True-licenseIsOsiApproved MirOS = True-licenseIsOsiApproved MIT = True-licenseIsOsiApproved Motosoto = True-licenseIsOsiApproved MPL_1_0 = True-licenseIsOsiApproved MPL_1_1 = True-licenseIsOsiApproved MPL_2_0_no_copyleft_exception = True-licenseIsOsiApproved MPL_2_0 = True-licenseIsOsiApproved MS_PL = True-licenseIsOsiApproved MS_RL = True-licenseIsOsiApproved MulanPSL_2_0 = True-licenseIsOsiApproved Multics = True-licenseIsOsiApproved NASA_1_3 = True-licenseIsOsiApproved Naumen = True-licenseIsOsiApproved NCSA = True-licenseIsOsiApproved NGPL = True-licenseIsOsiApproved Nokia = True-licenseIsOsiApproved NPOSL_3_0 = True-licenseIsOsiApproved NTP = True-licenseIsOsiApproved OCLC_2_0 = True-licenseIsOsiApproved OFL_1_1_no_RFN = True-licenseIsOsiApproved OFL_1_1_RFN = True-licenseIsOsiApproved OFL_1_1 = True-licenseIsOsiApproved OGTSL = True-licenseIsOsiApproved OSET_PL_2_1 = True-licenseIsOsiApproved OSL_1_0 = True-licenseIsOsiApproved OSL_2_0 = True-licenseIsOsiApproved OSL_2_1 = True-licenseIsOsiApproved OSL_3_0 = True-licenseIsOsiApproved PHP_3_01 = True-licenseIsOsiApproved PHP_3_0 = True-licenseIsOsiApproved PostgreSQL = True-licenseIsOsiApproved Python_2_0 = True-licenseIsOsiApproved QPL_1_0 = True-licenseIsOsiApproved RPL_1_1 = True-licenseIsOsiApproved RPL_1_5 = True-licenseIsOsiApproved RPSL_1_0 = True-licenseIsOsiApproved RSCPL = True-licenseIsOsiApproved SimPL_2_0 = True-licenseIsOsiApproved SISSL = True-licenseIsOsiApproved Sleepycat = True-licenseIsOsiApproved SPL_1_0 = True-licenseIsOsiApproved UCL_1_0 = True-licenseIsOsiApproved Unlicense = True-licenseIsOsiApproved UPL_1_0 = True-licenseIsOsiApproved VSL_1_0 = True-licenseIsOsiApproved W3C = True-licenseIsOsiApproved Watcom_1_0 = True-licenseIsOsiApproved Xnet = True-licenseIsOsiApproved Zlib = True-licenseIsOsiApproved ZPL_2_0 = True-licenseIsOsiApproved _ = False---- | Whether the license is considered libre by Free Software Foundation (FSF).------ See <https://www.gnu.org/licenses/license-list.en.html>------ @since 3.4.0.0----licenseIsFsfLibre :: LicenseId -> Bool-licenseIsFsfLibre AFL_1_1 = True-licenseIsFsfLibre AFL_1_2 = True-licenseIsFsfLibre AFL_2_0 = True-licenseIsFsfLibre AFL_2_1 = True-licenseIsFsfLibre AFL_3_0 = True-licenseIsFsfLibre AGPL_1_0 = True-licenseIsFsfLibre AGPL_3_0_only = True-licenseIsFsfLibre AGPL_3_0_or_later = True-licenseIsFsfLibre Apache_1_0 = True-licenseIsFsfLibre Apache_1_1 = True-licenseIsFsfLibre Apache_2_0 = True-licenseIsFsfLibre APSL_2_0 = True-licenseIsFsfLibre Artistic_2_0 = True-licenseIsFsfLibre BitTorrent_1_1 = True-licenseIsFsfLibre BSD_2_Clause_FreeBSD = True-licenseIsFsfLibre BSD_3_Clause_Clear = True-licenseIsFsfLibre BSD_3_Clause = True-licenseIsFsfLibre BSD_4_Clause = True-licenseIsFsfLibre BSL_1_0 = True-licenseIsFsfLibre CC_BY_4_0 = True-licenseIsFsfLibre CC_BY_SA_4_0 = True-licenseIsFsfLibre CC0_1_0 = True-licenseIsFsfLibre CDDL_1_0 = True-licenseIsFsfLibre CECILL_2_0 = True-licenseIsFsfLibre CECILL_B = True-licenseIsFsfLibre CECILL_C = True-licenseIsFsfLibre ClArtistic = True-licenseIsFsfLibre Condor_1_1 = True-licenseIsFsfLibre CPAL_1_0 = True-licenseIsFsfLibre CPL_1_0 = True-licenseIsFsfLibre ECL_2_0 = True-licenseIsFsfLibre EFL_2_0 = True-licenseIsFsfLibre EPL_1_0 = True-licenseIsFsfLibre EPL_2_0 = True-licenseIsFsfLibre EUDatagrid = True-licenseIsFsfLibre EUPL_1_1 = True-licenseIsFsfLibre EUPL_1_2 = True-licenseIsFsfLibre FSFAP = True-licenseIsFsfLibre FTL = True-licenseIsFsfLibre GFDL_1_1_only = True-licenseIsFsfLibre GFDL_1_1_or_later = True-licenseIsFsfLibre GFDL_1_2_only = True-licenseIsFsfLibre GFDL_1_2_or_later = True-licenseIsFsfLibre GFDL_1_3_only = True-licenseIsFsfLibre GFDL_1_3_or_later = True-licenseIsFsfLibre Gnuplot = True-licenseIsFsfLibre GPL_2_0_only = True-licenseIsFsfLibre GPL_2_0_or_later = True-licenseIsFsfLibre GPL_3_0_only = True-licenseIsFsfLibre GPL_3_0_or_later = True-licenseIsFsfLibre HPND = True-licenseIsFsfLibre IJG = True-licenseIsFsfLibre IMatix = True-licenseIsFsfLibre Imlib2 = True-licenseIsFsfLibre Intel = True-licenseIsFsfLibre IPA = True-licenseIsFsfLibre IPL_1_0 = True-licenseIsFsfLibre ISC = True-licenseIsFsfLibre LGPL_2_1_only = True-licenseIsFsfLibre LGPL_2_1_or_later = True-licenseIsFsfLibre LGPL_3_0_only = True-licenseIsFsfLibre LGPL_3_0_or_later = True-licenseIsFsfLibre LPL_1_02 = True-licenseIsFsfLibre LPPL_1_2 = True-licenseIsFsfLibre LPPL_1_3a = True-licenseIsFsfLibre MIT = True-licenseIsFsfLibre MPL_1_1 = True-licenseIsFsfLibre MPL_2_0 = True-licenseIsFsfLibre MS_PL = True-licenseIsFsfLibre MS_RL = True-licenseIsFsfLibre NCSA = True-licenseIsFsfLibre Nokia = True-licenseIsFsfLibre NOSL = True-licenseIsFsfLibre NPL_1_0 = True-licenseIsFsfLibre NPL_1_1 = True-licenseIsFsfLibre ODbL_1_0 = True-licenseIsFsfLibre OFL_1_0 = True-licenseIsFsfLibre OFL_1_1 = True-licenseIsFsfLibre OLDAP_2_3 = True-licenseIsFsfLibre OLDAP_2_7 = True-licenseIsFsfLibre OpenSSL = True-licenseIsFsfLibre OSL_1_0 = True-licenseIsFsfLibre OSL_1_1 = True-licenseIsFsfLibre OSL_2_0 = True-licenseIsFsfLibre OSL_2_1 = True-licenseIsFsfLibre OSL_3_0 = True-licenseIsFsfLibre PHP_3_01 = True-licenseIsFsfLibre Python_2_0 = True-licenseIsFsfLibre QPL_1_0 = True-licenseIsFsfLibre RPSL_1_0 = True-licenseIsFsfLibre Ruby = True-licenseIsFsfLibre SGI_B_2_0 = True-licenseIsFsfLibre SISSL = True-licenseIsFsfLibre Sleepycat = True-licenseIsFsfLibre SMLNJ = True-licenseIsFsfLibre SPL_1_0 = True-licenseIsFsfLibre Unlicense = True-licenseIsFsfLibre UPL_1_0 = True-licenseIsFsfLibre Vim = True-licenseIsFsfLibre W3C = True-licenseIsFsfLibre WTFPL = True-licenseIsFsfLibre X11 = True-licenseIsFsfLibre XFree86_1_1 = True-licenseIsFsfLibre Xinetd = True-licenseIsFsfLibre YPL_1_1 = True-licenseIsFsfLibre Zend_2_0 = True-licenseIsFsfLibre Zimbra_1_3 = True-licenseIsFsfLibre Zlib = True-licenseIsFsfLibre ZPL_2_0 = True-licenseIsFsfLibre ZPL_2_1 = True-licenseIsFsfLibre _ = False------------------------------------------------------------------------------------ Creation----------------------------------------------------------------------------------licenseIdList :: LicenseListVersion -> [LicenseId]-licenseIdList LicenseListVersion_3_0 =-    [ AGPL_1_0-    , BSD_2_Clause_FreeBSD-    , BSD_2_Clause_NetBSD-    ]-    ++ bulkOfLicenses-licenseIdList LicenseListVersion_3_2 =-    [ AGPL_1_0_only-    , AGPL_1_0_or_later-    , BSD_2_Clause_FreeBSD-    , BSD_2_Clause_NetBSD-    , Linux_OpenIB-    , MIT_0-    , ODC_By_1_0-    , TU_Berlin_1_0-    , TU_Berlin_2_0-    ]-    ++ bulkOfLicenses-licenseIdList LicenseListVersion_3_6 =-    [ AGPL_1_0_only-    , AGPL_1_0_or_later-    , Blessing-    , BlueOak_1_0_0-    , BSD_2_Clause_FreeBSD-    , BSD_2_Clause_NetBSD-    , BSD_3_Clause_Open_MPI-    , CC_PDDC-    , CERN_OHL_1_1-    , CERN_OHL_1_2-    , Copyleft_next_0_3_0-    , Copyleft_next_0_3_1-    , HPND_sell_variant-    , JPNIC-    , Libpng_2_0-    , Linux_OpenIB-    , MIT_0-    , ODC_By_1_0-    , OGL_UK_1_0-    , OGL_UK_2_0-    , OGL_UK_3_0-    , Parity_6_0_0-    , Sendmail_8_23-    , SHL_0_51-    , SHL_0_5-    , SSPL_1_0-    , TAPR_OHL_1_0-    , TU_Berlin_1_0-    , TU_Berlin_2_0-    ]-    ++ bulkOfLicenses-licenseIdList LicenseListVersion_3_9 =-    [ AGPL_1_0_only-    , AGPL_1_0_or_later-    , Blessing-    , BlueOak_1_0_0-    , BSD_2_Clause_FreeBSD-    , BSD_3_Clause_Open_MPI-    , CAL_1_0_Combined_Work_Exception-    , CAL_1_0-    , CC_PDDC-    , CERN_OHL_1_1-    , CERN_OHL_1_2-    , CERN_OHL_P_2_0-    , CERN_OHL_S_2_0-    , CERN_OHL_W_2_0-    , Copyleft_next_0_3_0-    , Copyleft_next_0_3_1-    , Etalab_2_0-    , Hippocratic_2_1-    , HPND_sell_variant-    , JPNIC-    , Libpng_2_0-    , Libselinux_1_0-    , Linux_OpenIB-    , MIT_0-    , MulanPSL_1_0-    , MulanPSL_2_0-    , NCGL_UK_2_0-    , NTP_0-    , O_UDA_1_0-    , ODC_By_1_0-    , OFL_1_0_no_RFN-    , OFL_1_0_RFN-    , OFL_1_1_no_RFN-    , OFL_1_1_RFN-    , OGC_1_0-    , OGL_Canada_2_0-    , OGL_UK_1_0-    , OGL_UK_2_0-    , OGL_UK_3_0-    , Parity_6_0_0-    , Parity_7_0_0-    , PolyForm_Noncommercial_1_0_0-    , PolyForm_Small_Business_1_0_0-    , PSF_2_0-    , Sendmail_8_23-    , SHL_0_51-    , SHL_0_5-    , SSH_OpenSSH-    , SSH_short-    , SSPL_1_0-    , TAPR_OHL_1_0-    , TU_Berlin_1_0-    , TU_Berlin_2_0-    , UCL_1_0-    ]-    ++ bulkOfLicenses-licenseIdList LicenseListVersion_3_10 =-    [ AGPL_1_0_only-    , AGPL_1_0_or_later-    , Blessing-    , BlueOak_1_0_0-    , BSD_2_Clause_FreeBSD-    , BSD_3_Clause_Open_MPI-    , CAL_1_0_Combined_Work_Exception-    , CAL_1_0-    , CC_PDDC-    , CERN_OHL_1_1-    , CERN_OHL_1_2-    , CERN_OHL_P_2_0-    , CERN_OHL_S_2_0-    , CERN_OHL_W_2_0-    , Copyleft_next_0_3_0-    , Copyleft_next_0_3_1-    , Etalab_2_0-    , Hippocratic_2_1-    , HPND_sell_variant-    , JPNIC-    , Libpng_2_0-    , Libselinux_1_0-    , Linux_OpenIB-    , MIT_0-    , MulanPSL_1_0-    , MulanPSL_2_0-    , NCGL_UK_2_0-    , NTP_0-    , O_UDA_1_0-    , ODC_By_1_0-    , OFL_1_0_no_RFN-    , OFL_1_0_RFN-    , OFL_1_1_no_RFN-    , OFL_1_1_RFN-    , OGC_1_0-    , OGL_Canada_2_0-    , OGL_UK_1_0-    , OGL_UK_2_0-    , OGL_UK_3_0-    , Parity_6_0_0-    , Parity_7_0_0-    , PolyForm_Noncommercial_1_0_0-    , PolyForm_Small_Business_1_0_0-    , PSF_2_0-    , Sendmail_8_23-    , SHL_0_51-    , SHL_0_5-    , SSH_OpenSSH-    , SSH_short-    , SSPL_1_0-    , TAPR_OHL_1_0-    , TU_Berlin_1_0-    , TU_Berlin_2_0-    , UCL_1_0-    ]-    ++ bulkOfLicenses---- | Create a 'LicenseId' from a 'String'.-mkLicenseId :: LicenseListVersion -> String -> Maybe LicenseId-mkLicenseId LicenseListVersion_3_0  s = Map.lookup s stringLookup_3_0-mkLicenseId LicenseListVersion_3_2  s = Map.lookup s stringLookup_3_2-mkLicenseId LicenseListVersion_3_6  s = Map.lookup s stringLookup_3_6-mkLicenseId LicenseListVersion_3_9  s = Map.lookup s stringLookup_3_9-mkLicenseId LicenseListVersion_3_10 s = Map.lookup s stringLookup_3_10--stringLookup_3_0 :: Map String LicenseId-stringLookup_3_0 = Map.fromList $ map (\i -> (licenseId i, i)) $-    licenseIdList LicenseListVersion_3_0--stringLookup_3_2 :: Map String LicenseId-stringLookup_3_2 = Map.fromList $ map (\i -> (licenseId i, i)) $-    licenseIdList LicenseListVersion_3_2--stringLookup_3_6 :: Map String LicenseId-stringLookup_3_6 = Map.fromList $ map (\i -> (licenseId i, i)) $-    licenseIdList LicenseListVersion_3_6--stringLookup_3_9 :: Map String LicenseId-stringLookup_3_9 = Map.fromList $ map (\i -> (licenseId i, i)) $-    licenseIdList LicenseListVersion_3_9--stringLookup_3_10 :: Map String LicenseId-stringLookup_3_10 = Map.fromList $ map (\i -> (licenseId i, i)) $-    licenseIdList LicenseListVersion_3_10----  | Licenses in all SPDX License lists-bulkOfLicenses :: [LicenseId]-bulkOfLicenses =-    [ NullBSD-    , AAL-    , Abstyles-    , Adobe_2006-    , Adobe_Glyph-    , ADSL-    , AFL_1_1-    , AFL_1_2-    , AFL_2_0-    , AFL_2_1-    , AFL_3_0-    , Afmparse-    , AGPL_3_0_only-    , AGPL_3_0_or_later-    , Aladdin-    , AMDPLPA-    , AML-    , AMPAS-    , ANTLR_PD-    , Apache_1_0-    , Apache_1_1-    , Apache_2_0-    , APAFML-    , APL_1_0-    , APSL_1_0-    , APSL_1_1-    , APSL_1_2-    , APSL_2_0-    , Artistic_1_0_cl8-    , Artistic_1_0_Perl-    , Artistic_1_0-    , Artistic_2_0-    , Bahyph-    , Barr-    , Beerware-    , BitTorrent_1_0-    , BitTorrent_1_1-    , Borceux-    , BSD_1_Clause-    , BSD_2_Clause_Patent-    , BSD_2_Clause-    , BSD_3_Clause_Attribution-    , BSD_3_Clause_Clear-    , BSD_3_Clause_LBNL-    , BSD_3_Clause_No_Nuclear_License_2014-    , BSD_3_Clause_No_Nuclear_License-    , BSD_3_Clause_No_Nuclear_Warranty-    , BSD_3_Clause-    , BSD_4_Clause_UC-    , BSD_4_Clause-    , BSD_Protection-    , BSD_Source_Code-    , BSL_1_0-    , Bzip2_1_0_5-    , Bzip2_1_0_6-    , Caldera-    , CATOSL_1_1-    , CC_BY_1_0-    , CC_BY_2_0-    , CC_BY_2_5-    , CC_BY_3_0-    , CC_BY_4_0-    , CC_BY_NC_1_0-    , CC_BY_NC_2_0-    , CC_BY_NC_2_5-    , CC_BY_NC_3_0-    , CC_BY_NC_4_0-    , CC_BY_NC_ND_1_0-    , CC_BY_NC_ND_2_0-    , CC_BY_NC_ND_2_5-    , CC_BY_NC_ND_3_0-    , CC_BY_NC_ND_4_0-    , CC_BY_NC_SA_1_0-    , CC_BY_NC_SA_2_0-    , CC_BY_NC_SA_2_5-    , CC_BY_NC_SA_3_0-    , CC_BY_NC_SA_4_0-    , CC_BY_ND_1_0-    , CC_BY_ND_2_0-    , CC_BY_ND_2_5-    , CC_BY_ND_3_0-    , CC_BY_ND_4_0-    , CC_BY_SA_1_0-    , CC_BY_SA_2_0-    , CC_BY_SA_2_5-    , CC_BY_SA_3_0-    , CC_BY_SA_4_0-    , CC0_1_0-    , CDDL_1_0-    , CDDL_1_1-    , CDLA_Permissive_1_0-    , CDLA_Sharing_1_0-    , CECILL_1_0-    , CECILL_1_1-    , CECILL_2_0-    , CECILL_2_1-    , CECILL_B-    , CECILL_C-    , ClArtistic-    , CNRI_Jython-    , CNRI_Python_GPL_Compatible-    , CNRI_Python-    , Condor_1_1-    , CPAL_1_0-    , CPL_1_0-    , CPOL_1_02-    , Crossword-    , CrystalStacker-    , CUA_OPL_1_0-    , Cube-    , Curl-    , D_FSL_1_0-    , Diffmark-    , DOC-    , Dotseqn-    , DSDP-    , Dvipdfm-    , ECL_1_0-    , ECL_2_0-    , EFL_1_0-    , EFL_2_0-    , EGenix-    , Entessa-    , EPL_1_0-    , EPL_2_0-    , ErlPL_1_1-    , EUDatagrid-    , EUPL_1_0-    , EUPL_1_1-    , EUPL_1_2-    , Eurosym-    , Fair-    , Frameworx_1_0-    , FreeImage-    , FSFAP-    , FSFULLR-    , FSFUL-    , FTL-    , GFDL_1_1_only-    , GFDL_1_1_or_later-    , GFDL_1_2_only-    , GFDL_1_2_or_later-    , GFDL_1_3_only-    , GFDL_1_3_or_later-    , Giftware-    , GL2PS-    , Glide-    , Glulxe-    , Gnuplot-    , GPL_1_0_only-    , GPL_1_0_or_later-    , GPL_2_0_only-    , GPL_2_0_or_later-    , GPL_3_0_only-    , GPL_3_0_or_later-    , GSOAP_1_3b-    , HaskellReport-    , HPND-    , IBM_pibs-    , ICU-    , IJG-    , ImageMagick-    , IMatix-    , Imlib2-    , Info_ZIP-    , Intel_ACPI-    , Intel-    , Interbase_1_0-    , IPA-    , IPL_1_0-    , ISC-    , JasPer_2_0-    , JSON-    , LAL_1_2-    , LAL_1_3-    , Latex2e-    , Leptonica-    , LGPL_2_0_only-    , LGPL_2_0_or_later-    , LGPL_2_1_only-    , LGPL_2_1_or_later-    , LGPL_3_0_only-    , LGPL_3_0_or_later-    , LGPLLR-    , Libpng-    , Libtiff-    , LiLiQ_P_1_1-    , LiLiQ_R_1_1-    , LiLiQ_Rplus_1_1-    , LPL_1_02-    , LPL_1_0-    , LPPL_1_0-    , LPPL_1_1-    , LPPL_1_2-    , LPPL_1_3a-    , LPPL_1_3c-    , MakeIndex-    , MirOS-    , MIT_advertising-    , MIT_CMU-    , MIT_enna-    , MIT_feh-    , MITNFA-    , MIT-    , Motosoto-    , Mpich2-    , MPL_1_0-    , MPL_1_1-    , MPL_2_0_no_copyleft_exception-    , MPL_2_0-    , MS_PL-    , MS_RL-    , MTLL-    , Multics-    , Mup-    , NASA_1_3-    , Naumen-    , NBPL_1_0-    , NCSA-    , Net_SNMP-    , NetCDF-    , Newsletr-    , NGPL-    , NLOD_1_0-    , NLPL-    , Nokia-    , NOSL-    , Noweb-    , NPL_1_0-    , NPL_1_1-    , NPOSL_3_0-    , NRL-    , NTP-    , OCCT_PL-    , OCLC_2_0-    , ODbL_1_0-    , OFL_1_0-    , OFL_1_1-    , OGTSL-    , OLDAP_1_1-    , OLDAP_1_2-    , OLDAP_1_3-    , OLDAP_1_4-    , OLDAP_2_0_1-    , OLDAP_2_0-    , OLDAP_2_1-    , OLDAP_2_2_1-    , OLDAP_2_2_2-    , OLDAP_2_2-    , OLDAP_2_3-    , OLDAP_2_4-    , OLDAP_2_5-    , OLDAP_2_6-    , OLDAP_2_7-    , OLDAP_2_8-    , OML-    , OpenSSL-    , OPL_1_0-    , OSET_PL_2_1-    , OSL_1_0-    , OSL_1_1-    , OSL_2_0-    , OSL_2_1-    , OSL_3_0-    , PDDL_1_0-    , PHP_3_01-    , PHP_3_0-    , Plexus-    , PostgreSQL-    , Psfrag-    , Psutils-    , Python_2_0-    , Qhull-    , QPL_1_0-    , Rdisc-    , RHeCos_1_1-    , RPL_1_1-    , RPL_1_5-    , RPSL_1_0-    , RSA_MD-    , RSCPL-    , Ruby-    , SAX_PD-    , Saxpath-    , SCEA-    , Sendmail-    , SGI_B_1_0-    , SGI_B_1_1-    , SGI_B_2_0-    , SimPL_2_0-    , SISSL_1_2-    , SISSL-    , Sleepycat-    , SMLNJ-    , SMPPL-    , SNIA-    , Spencer_86-    , Spencer_94-    , Spencer_99-    , SPL_1_0-    , SugarCRM_1_1_3-    , SWL-    , TCL-    , TCP_wrappers-    , TMate-    , TORQUE_1_1-    , TOSL-    , Unicode_DFS_2015-    , Unicode_DFS_2016-    , Unicode_TOU-    , Unlicense-    , UPL_1_0-    , Vim-    , VOSTROM-    , VSL_1_0-    , W3C_19980720-    , W3C_20150513-    , W3C-    , Watcom_1_0-    , Wsuipa-    , WTFPL-    , X11-    , Xerox-    , XFree86_1_1-    , Xinetd-    , Xnet-    , Xpp-    , XSkat-    , YPL_1_0-    , YPL_1_1-    , Zed-    , Zend_2_0-    , Zimbra_1_3-    , Zimbra_1_4-    , Zlib_acknowledgement-    , Zlib-    , ZPL_1_1-    , ZPL_2_0-    , ZPL_2_1-    ]
− src/Distribution/SPDX/LicenseListVersion.hs 
@@ -1,22 +0,0 @@-module Distribution.SPDX.LicenseListVersion (-    LicenseListVersion (..),-    cabalSpecVersionToSPDXListVersion,-    ) where--import Distribution.CabalSpecVersion---- | SPDX License List version @Cabal@ is aware of.-data LicenseListVersion-    = LicenseListVersion_3_0-    | LicenseListVersion_3_2-    | LicenseListVersion_3_6-    | LicenseListVersion_3_9-    | LicenseListVersion_3_10-  deriving (Eq, Ord, Show, Enum, Bounded)--cabalSpecVersionToSPDXListVersion :: CabalSpecVersion -> LicenseListVersion-cabalSpecVersionToSPDXListVersion CabalSpecV3_6 = LicenseListVersion_3_10-cabalSpecVersionToSPDXListVersion CabalSpecV3_4 = LicenseListVersion_3_9-cabalSpecVersionToSPDXListVersion CabalSpecV3_0 = LicenseListVersion_3_6-cabalSpecVersionToSPDXListVersion CabalSpecV2_4 = LicenseListVersion_3_2-cabalSpecVersionToSPDXListVersion _             = LicenseListVersion_3_0
− src/Distribution/SPDX/LicenseReference.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.SPDX.LicenseReference (-    LicenseRef,-    licenseRef,-    licenseDocumentRef,-    mkLicenseRef,-    mkLicenseRef',-    ) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Utils.Generic (isAsciiAlphaNum)-import Distribution.Pretty-import Distribution.Parsec--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp---- | A user defined license reference denoted by @LicenseRef-[idstring]@ (for a license not on the SPDX License List);-data LicenseRef = LicenseRef-    { _lrDocument :: !(Maybe String)-    , _lrLicense  :: !String-    }-  deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)---- | License reference.-licenseRef :: LicenseRef -> String-licenseRef = _lrLicense---- | Document reference.-licenseDocumentRef :: LicenseRef -> Maybe String-licenseDocumentRef = _lrDocument--instance Binary LicenseRef-instance Structured LicenseRef--instance NFData LicenseRef where-    rnf (LicenseRef d l) = rnf d `seq` rnf l--instance Pretty LicenseRef where-    pretty (LicenseRef Nothing l) = Disp.text "LicenseRef-" <<>> Disp.text l-    pretty (LicenseRef (Just d) l) =-        Disp.text "DocumentRef-" <<>> Disp.text d <<>> Disp.char ':' <<>> Disp.text "LicenseRef-" <<>> Disp.text l--instance Parsec LicenseRef where-    parsec = name <|> doc-      where-        name = do-            _ <- P.string "LicenseRef-"-            n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.'-            pure (LicenseRef Nothing n)--        doc = do-            _ <- P.string "DocumentRef-"-            d <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.'-            _ <- P.char ':'-            _ <- P.string "LicenseRef-"-            n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.'-            pure (LicenseRef (Just d) n)---- | Create 'LicenseRef' from optional document ref and name.-mkLicenseRef :: Maybe String -> String -> Maybe LicenseRef-mkLicenseRef d l = do-    d' <- traverse checkIdString d-    l' <- checkIdString l-    pure (LicenseRef d' l')-  where-    checkIdString s-        | all (\c -> isAsciiAlphaNum c || c == '-' || c == '.') s = Just s-        | otherwise = Nothing---- | Like 'mkLicenseRef' but convert invalid characters into @-@.-mkLicenseRef' :: Maybe String -> String -> LicenseRef-mkLicenseRef' d l = LicenseRef (fmap f d) (f l)-  where-    f = map g-    g c | isAsciiAlphaNum c || c == '-' || c == '.' = c-        | otherwise                                 = '-'
src/Distribution/Simple.hs view
@@ -1,836 +1,1132 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple--- Copyright   :  Isaac Jones 2003-2005--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This is the command line front end to the Simple build system. When given--- the parsed command-line args and package information, is able to perform--- basic commands like configure, build, install, register, etc.------ This module exports the main functions that Setup.hs scripts use. It--- re-exports the 'UserHooks' type, the standard entry points like--- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of--- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own--- behaviour.------ This module isn't called \"Simple\" because it's simple.  Far from--- it.  It's called \"Simple\" because it does complicated things to--- 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.--{--Work around this warning:-libraries/Cabal/Distribution/Simple.hs:78:0:-    Warning: In the use of `runTests'-             (imported from Distribution.Simple.UserHooks):-             Deprecated: "Please use the new testing interface instead!"--}-{-# OPTIONS_GHC -fno-warn-deprecations #-}--module Distribution.Simple (-        module Distribution.Package,-        module Distribution.Version,-        module Distribution.License,-        module Distribution.Simple.Compiler,-        module Language.Haskell.Extension,-        -- * Simple interface-        defaultMain, defaultMainNoRead, defaultMainArgs,-        -- * Customization-        UserHooks(..), Args,-        defaultMainWithHooks, defaultMainWithHooksArgs,-        defaultMainWithHooksNoRead, defaultMainWithHooksNoReadArgs,-        -- ** Standard sets of hooks-        simpleUserHooks,-        autoconfUserHooks,-        emptyUserHooks,-  ) where--import Control.Exception (try)--import Prelude ()-import Distribution.Compat.Prelude---- local-import Distribution.Simple.Compiler-import Distribution.Simple.UserHooks-import Distribution.Package-import Distribution.PackageDescription-import Distribution.PackageDescription.Configuration-import Distribution.Simple.Program-import Distribution.Simple.Program.Db-import Distribution.Simple.PreProcess-import Distribution.Simple.Setup-import Distribution.Simple.Command--import Distribution.Simple.Build-import Distribution.Simple.SrcDist-import Distribution.Simple.Register--import Distribution.Simple.Configure--import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Bench-import Distribution.Simple.BuildPaths-import Distribution.Simple.Test-import Distribution.Simple.Install-import Distribution.Simple.Haddock-import Distribution.Simple.Utils-import Distribution.Utils.NubList-import Distribution.Verbosity-import Language.Haskell.Extension-import Distribution.Version-import Distribution.License-import Distribution.Pretty-import Distribution.System (buildPlatform)---- Base-import System.Environment (getArgs, getProgName)-import System.Directory   (removeFile, doesFileExist-                          ,doesDirectoryExist, removeDirectoryRecursive)-import System.FilePath    (searchPathSeparator, takeDirectory, (</>),-                           splitDirectories, dropDrive)-#ifdef mingw32_HOST_OS-import System.FilePath    (normalise, splitDrive)-#endif-import Distribution.Compat.ResponseFile (expandResponse)-import Distribution.Compat.Directory        (makeAbsolute)-import Distribution.Compat.Environment      (getEnvironment)-import Distribution.Compat.GetShortPathName (getShortPathName)--import Data.List       (unionBy, (\\))--import Distribution.PackageDescription.Parsec---- | A simple implementation of @main@ for a Cabal setup script.--- It reads the package description file using IO, and performs the--- action specified on the command line.-defaultMain :: IO ()-defaultMain = getArgs >>= defaultMainHelper simpleUserHooks---- | A version of 'defaultMain' that is passed the command line--- arguments, rather than getting them from the environment.-defaultMainArgs :: [String] -> IO ()-defaultMainArgs = defaultMainHelper simpleUserHooks---- | A customizable version of 'defaultMain'.-defaultMainWithHooks :: UserHooks -> IO ()-defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks---- | A customizable version of 'defaultMain' that also takes the command--- line arguments.-defaultMainWithHooksArgs :: UserHooks -> [String] -> IO ()-defaultMainWithHooksArgs = defaultMainHelper---- | Like 'defaultMain', but accepts the package description as input--- rather than using IO to read it.-defaultMainNoRead :: GenericPackageDescription -> IO ()-defaultMainNoRead = defaultMainWithHooksNoRead simpleUserHooks---- | A customizable version of 'defaultMainNoRead'.-defaultMainWithHooksNoRead :: UserHooks -> GenericPackageDescription -> IO ()-defaultMainWithHooksNoRead hooks pkg_descr =-  getArgs >>=-  defaultMainHelper hooks { readDesc = return (Just pkg_descr) }---- | A customizable version of 'defaultMainNoRead' that also takes the--- command line arguments.------ @since 2.2.0.0-defaultMainWithHooksNoReadArgs :: UserHooks -> GenericPackageDescription -> [String] -> IO ()-defaultMainWithHooksNoReadArgs hooks pkg_descr =-  defaultMainHelper hooks { readDesc = return (Just pkg_descr) }--defaultMainHelper :: UserHooks -> Args -> IO ()-defaultMainHelper hooks args = topHandler $ do-  args' <- expandResponse args-  case commandsRun (globalCommand commands) commands args' of-    CommandHelp   help                 -> printHelp help-    CommandList   opts                 -> printOptionsList opts-    CommandErrors errs                 -> printErrors errs-    CommandReadyToGo (flags, commandParse)  ->-      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 = addKnownPrograms (hookedPrograms hooks) defaultProgramDb-    commands =-      [configureCommand progs `commandAddAction`-        \fs as -> configureAction hooks fs as >> return ()-      ,buildCommand     progs `commandAddAction` buildAction        hooks-      ,showBuildInfoCommand progs `commandAddAction` showBuildInfoAction    hooks-      ,replCommand      progs `commandAddAction` replAction         hooks-      ,installCommand         `commandAddAction` installAction      hooks-      ,copyCommand            `commandAddAction` copyAction         hooks-      ,haddockCommand         `commandAddAction` haddockAction      hooks-      ,cleanCommand           `commandAddAction` cleanAction        hooks-      ,sdistCommand           `commandAddAction` sdistAction        hooks-      ,hscolourCommand        `commandAddAction` hscolourAction     hooks-      ,registerCommand        `commandAddAction` registerAction     hooks-      ,unregisterCommand      `commandAddAction` unregisterAction   hooks-      ,testCommand            `commandAddAction` testAction         hooks-      ,benchmarkCommand       `commandAddAction` benchAction        hooks-      ]---- | Combine the preprocessors in the given hooks with the--- preprocessors built into cabal.-allSuffixHandlers :: UserHooks-                  -> [PPSuffixHandler]-allSuffixHandlers hooks-    = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers-    where-      overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler]-      overridesPP = unionBy (\x y -> fst x == fst y)--configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo-configureAction hooks flags args = do-    distPref <- findDistPrefOrDefault (configDistPref flags)-    let flags' = flags { configDistPref = toFlag distPref-                       , configArgs = args }--    -- See docs for 'HookedBuildInfo'-    pbi <- preConf hooks args flags'--    (mb_pd_file, pkg_descr0) <- confPkgDescr hooks verbosity-                                    (flagToMaybe (configCabalFilePath flags))--    let epkg_descr = (pkg_descr0, pbi)--    localbuildinfo0 <- confHook hooks epkg_descr flags'--    -- remember the .cabal filename if we know it-    -- and all the extra command line args-    let localbuildinfo = localbuildinfo0 {-                           pkgDescrFile = mb_pd_file,-                           extraConfigArgs = args-                         }-    writePersistBuildConfig distPref localbuildinfo--    let pkg_descr = localPkgDescr localbuildinfo-    postConf hooks args flags' pkg_descr localbuildinfo-    return localbuildinfo-  where-    verbosity = fromFlag (configVerbosity flags)--confPkgDescr :: UserHooks -> Verbosity -> Maybe FilePath-             -> IO (Maybe FilePath, GenericPackageDescription)-confPkgDescr hooks verbosity mb_path = do-  mdescr <- readDesc hooks-  case mdescr of-    Just descr -> return (Nothing, descr)-    Nothing -> do-        pdfile <- case mb_path of-                    Nothing -> defaultPackageDesc verbosity-                    Just path -> return path-        info verbosity "Using Parsec parser"-        descr  <- readGenericPackageDescription verbosity pdfile-        return (Just pdfile, descr)--buildAction :: UserHooks -> BuildFlags -> Args -> IO ()-buildAction hooks flags args = do-  distPref <- findDistPrefOrDefault (buildDistPref flags)-  let verbosity = fromFlag $ buildVerbosity flags-  lbi <- getBuildConfig hooks verbosity distPref-  let flags' = flags { buildDistPref = toFlag distPref-                     , buildCabalFilePath = maybeToFlag (cabalFilePath lbi)}--  progs <- reconfigurePrograms verbosity-             (buildProgramPaths flags')-             (buildProgramArgs flags')-             (withPrograms lbi)--  hookedAction verbosity preBuild buildHook postBuild-               (return lbi { withPrograms = progs })-               hooks flags' { buildArgs = args } args--showBuildInfoAction :: UserHooks -> ShowBuildInfoFlags -> Args -> IO ()-showBuildInfoAction hooks (ShowBuildInfoFlags flags fileOutput) args = do-  distPref <- findDistPrefOrDefault (buildDistPref flags)-  let verbosity = fromFlag $ buildVerbosity flags-  lbi <- getBuildConfig hooks verbosity distPref-  let flags' = flags { buildDistPref = toFlag distPref-                     , buildCabalFilePath = maybeToFlag (cabalFilePath lbi)-                     }--  progs <- reconfigurePrograms verbosity-             (buildProgramPaths flags')-             (buildProgramArgs flags')-             (withPrograms lbi)--  pbi <- preBuild hooks args flags'-  let lbi' = lbi { withPrograms = progs }-      pkg_descr0 = localPkgDescr lbi'-      pkg_descr = updatePackageDescription pbi pkg_descr0-      -- TODO: Somehow don't ignore build hook?-  buildInfoString <- showBuildInfo pkg_descr lbi' flags--  case fileOutput of-    Nothing -> putStr buildInfoString-    Just fp -> writeFile fp buildInfoString--  postBuild hooks args flags' pkg_descr lbi'--replAction :: UserHooks -> ReplFlags -> Args -> IO ()-replAction hooks flags args = do-  distPref <- findDistPrefOrDefault (replDistPref flags)-  let verbosity = fromFlag $ replVerbosity flags-      flags' = flags { replDistPref = toFlag distPref }--  lbi <- getBuildConfig hooks verbosity distPref-  progs <- reconfigurePrograms verbosity-             (replProgramPaths flags')-             (replProgramArgs flags')-             (withPrograms lbi)--  -- As far as I can tell, the only reason this doesn't use-  -- 'hookedActionWithArgs' is because the arguments of 'replHook'-  -- takes the args explicitly.  UGH.   -- ezyang-  pbi <- preRepl hooks args flags'-  let pkg_descr0 = localPkgDescr lbi-  sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi-  let pkg_descr = updatePackageDescription pbi pkg_descr0-      lbi' = lbi { withPrograms = progs-                 , localPkgDescr = pkg_descr }-  replHook hooks pkg_descr lbi' hooks flags' args-  postRepl hooks args flags' pkg_descr lbi'--hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO ()-hscolourAction hooks flags args = do-    distPref <- findDistPrefOrDefault (hscolourDistPref flags)-    let verbosity = fromFlag $ hscolourVerbosity flags-    lbi <- getBuildConfig hooks verbosity distPref-    let flags' = flags { hscolourDistPref = toFlag distPref-                       , hscolourCabalFilePath = maybeToFlag (cabalFilePath lbi)}--    hookedAction verbosity preHscolour hscolourHook postHscolour-                 (getBuildConfig hooks verbosity distPref)-                 hooks flags' args--haddockAction :: UserHooks -> HaddockFlags -> Args -> IO ()-haddockAction hooks flags args = do-  distPref <- findDistPrefOrDefault (haddockDistPref flags)-  let verbosity = fromFlag $ haddockVerbosity flags-  lbi <- getBuildConfig hooks verbosity distPref-  let flags' = flags { haddockDistPref = toFlag distPref-                     , haddockCabalFilePath = maybeToFlag (cabalFilePath lbi)}--  progs <- reconfigurePrograms verbosity-             (haddockProgramPaths flags')-             (haddockProgramArgs flags')-             (withPrograms lbi)--  hookedAction verbosity preHaddock haddockHook postHaddock-               (return lbi { withPrograms = progs })-               hooks flags' { haddockArgs = args } args--cleanAction :: UserHooks -> CleanFlags -> Args -> IO ()-cleanAction hooks flags args = do-    distPref <- findDistPrefOrDefault (cleanDistPref flags)--    elbi <- tryGetBuildConfig hooks verbosity distPref-    let flags' = flags { cleanDistPref = toFlag distPref-                       , cleanCabalFilePath = case elbi of-                           Left _ -> mempty-                           Right lbi -> maybeToFlag (cabalFilePath lbi)}--    pbi <- preClean hooks args flags'--    (_, ppd) <- confPkgDescr hooks verbosity Nothing-    -- It might seem like we are doing something clever here-    -- but we're really not: if you look at the implementation-    -- of 'clean' in the end all the package description is-    -- used for is to clear out @extra-tmp-files@.  IMO,-    -- the configure script goo should go into @dist@ too!-    --          -- ezyang-    let pkg_descr0 = flattenPackageDescription ppd-    -- We don't sanity check for clean as an error-    -- here would prevent cleaning:-    --sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi-    let pkg_descr = updatePackageDescription pbi pkg_descr0--    cleanHook hooks pkg_descr () hooks flags'-    postClean hooks args flags' pkg_descr ()-  where-    verbosity = fromFlag (cleanVerbosity flags)--copyAction :: UserHooks -> CopyFlags -> Args -> IO ()-copyAction hooks flags args = do-    distPref <- findDistPrefOrDefault (copyDistPref flags)-    let verbosity = fromFlag $ copyVerbosity flags-    lbi <- getBuildConfig hooks verbosity distPref-    let flags' = flags { copyDistPref = toFlag distPref-                       , copyCabalFilePath = maybeToFlag (cabalFilePath lbi)}-    hookedAction verbosity preCopy copyHook postCopy-                 (getBuildConfig hooks verbosity distPref)-                 hooks flags' { copyArgs = args } args--installAction :: UserHooks -> InstallFlags -> Args -> IO ()-installAction hooks flags args = do-    distPref <- findDistPrefOrDefault (installDistPref flags)-    let verbosity = fromFlag $ installVerbosity flags-    lbi <- getBuildConfig hooks verbosity distPref-    let flags' = flags { installDistPref = toFlag distPref-                       , installCabalFilePath = maybeToFlag (cabalFilePath lbi)}-    hookedAction verbosity preInst instHook postInst-                 (getBuildConfig hooks verbosity distPref)-                 hooks flags' args---- Since Cabal-3.4 UserHooks are completely ignored-sdistAction :: UserHooks -> SDistFlags -> Args -> IO ()-sdistAction _hooks flags _args = do-    (_, ppd) <- confPkgDescr emptyUserHooks verbosity Nothing-    let pkg_descr = flattenPackageDescription ppd-    sdist pkg_descr flags srcPref knownSuffixHandlers-  where-    verbosity = fromFlag (sDistVerbosity flags)--testAction :: UserHooks -> TestFlags -> Args -> IO ()-testAction hooks flags args = do-    distPref <- findDistPrefOrDefault (testDistPref flags)-    let verbosity = fromFlag $ testVerbosity flags-        flags' = flags { testDistPref = toFlag distPref }--    hookedActionWithArgs verbosity preTest testHook postTest-            (getBuildConfig hooks verbosity distPref)-            hooks flags' args--benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO ()-benchAction hooks flags args = do-    distPref <- findDistPrefOrDefault (benchmarkDistPref flags)-    let verbosity = fromFlag $ benchmarkVerbosity flags-        flags' = flags { benchmarkDistPref = toFlag distPref }-    hookedActionWithArgs verbosity preBench benchHook postBench-            (getBuildConfig hooks verbosity distPref)-            hooks flags' args--registerAction :: UserHooks -> RegisterFlags -> Args -> IO ()-registerAction hooks flags args = do-    distPref <- findDistPrefOrDefault (regDistPref flags)-    let verbosity = fromFlag $ regVerbosity flags-    lbi <- getBuildConfig hooks verbosity distPref-    let flags' = flags { regDistPref = toFlag distPref-                       , regCabalFilePath = maybeToFlag (cabalFilePath lbi)}-    hookedAction verbosity preReg regHook postReg-                 (getBuildConfig hooks verbosity distPref)-                 hooks flags' { regArgs = args } args--unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO ()-unregisterAction hooks flags args = do-    distPref <- findDistPrefOrDefault (regDistPref flags)-    let verbosity = fromFlag $ regVerbosity flags-    lbi <- getBuildConfig hooks verbosity distPref-    let flags' = flags { regDistPref = toFlag distPref-                       , regCabalFilePath = maybeToFlag (cabalFilePath lbi)}-    hookedAction verbosity preUnreg unregHook postUnreg-                 (getBuildConfig hooks verbosity distPref)-                 hooks flags' args--hookedAction-  :: Verbosity-  -> (UserHooks -> Args -> flags -> IO HookedBuildInfo)-  -> (UserHooks -> PackageDescription -> LocalBuildInfo-                -> UserHooks -> flags -> IO ())-  -> (UserHooks -> Args -> flags -> PackageDescription-                -> LocalBuildInfo -> IO ())-  -> IO LocalBuildInfo-  -> UserHooks -> flags -> Args -> IO ()-hookedAction verbosity pre_hook cmd_hook =-    hookedActionWithArgs verbosity pre_hook-    (\h _ pd lbi uh flags ->-        cmd_hook h pd lbi uh flags)--hookedActionWithArgs-  :: Verbosity-  -> (UserHooks -> Args -> flags -> IO HookedBuildInfo)-  -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo-                -> UserHooks -> flags -> IO ())-  -> (UserHooks -> Args -> flags -> PackageDescription-                -> LocalBuildInfo -> IO ())-  -> IO LocalBuildInfo-  -> UserHooks -> flags -> Args -> IO ()-hookedActionWithArgs verbosity pre_hook cmd_hook post_hook-  get_build_config hooks flags args = do-   pbi <- pre_hook hooks args flags-   lbi0 <- get_build_config-   let pkg_descr0 = localPkgDescr lbi0-   sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi-   let pkg_descr = updatePackageDescription pbi pkg_descr0-       lbi = lbi0 { localPkgDescr = pkg_descr }-   cmd_hook hooks args pkg_descr lbi hooks flags-   post_hook hooks args flags pkg_descr lbi--sanityCheckHookedBuildInfo-  :: Verbosity -> PackageDescription -> HookedBuildInfo -> IO ()-sanityCheckHookedBuildInfo verbosity-  (PackageDescription { library = Nothing }) (Just _,_)-    = die' verbosity $ "The buildinfo contains info for a library, "-      ++ "but the package does not have a library."--sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes)-    | exe1 : _ <- nonExistant-    = die' verbosity $ "The buildinfo contains info for an executable called '"-      ++ prettyShow exe1 ++ "' but the package does not have a "-      ++ "executable with that name."-  where-    pkgExeNames  = nub (map exeName (executables pkg_descr))-    hookExeNames = nub (map fst hookExes)-    nonExistant  = hookExeNames \\ pkgExeNames--sanityCheckHookedBuildInfo _ _ _ = return ()---- | Try to read the 'localBuildInfoFile'-tryGetBuildConfig :: UserHooks -> Verbosity -> FilePath-                  -> IO (Either ConfigStateFileError LocalBuildInfo)-tryGetBuildConfig u v = try . getBuildConfig u v----- | Read the 'localBuildInfoFile' or throw an exception.-getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo-getBuildConfig hooks verbosity distPref = do-  lbi_wo_programs <- getPersistBuildConfig distPref-  -- Restore info about unconfigured programs, since it is not serialized-  let lbi = lbi_wo_programs {-    withPrograms = restoreProgramDb-                     (builtinPrograms ++ hookedPrograms hooks)-                     (withPrograms lbi_wo_programs)-  }--  case pkgDescrFile lbi of-    Nothing -> return lbi-    Just pkg_descr_file -> do-      outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file-      if outdated-        then reconfigure pkg_descr_file lbi-        else return lbi--  where-    reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo-    reconfigure pkg_descr_file lbi = do-      notice verbosity $ pkg_descr_file ++ " has been changed. "-                      ++ "Re-configuring with most recently used options. "-                      ++ "If this fails, please run configure manually.\n"-      let cFlags = configFlags lbi-      let cFlags' = cFlags {-            -- Since the list of unconfigured programs is not serialized,-            -- restore it to the same value as normally used at the beginning-            -- of a configure run:-            configPrograms_ = fmap (restoreProgramDb-                                      (builtinPrograms ++ hookedPrograms hooks))-                               `fmap` configPrograms_ cFlags,--            -- Use the current, not saved verbosity level:-            configVerbosity = Flag verbosity-          }-      configureAction hooks cFlags' (extraConfigArgs lbi)----- ----------------------------------------------------------------------------- Cleaning--clean :: PackageDescription -> CleanFlags -> IO ()-clean pkg_descr flags = do-    let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags-    notice verbosity "cleaning..."--    maybeConfig <- if fromFlag (cleanSaveConf flags)-                     then maybeGetPersistBuildConfig distPref-                     else return Nothing--    -- remove the whole dist/ directory rather than tracking exactly what files-    -- we created in there.-    chattyTry "removing dist/" $ do-      exists <- doesDirectoryExist distPref-      when exists (removeDirectoryRecursive distPref)--    -- Any extra files the user wants to remove-    traverse_ removeFileOrDirectory (extraTmpFiles pkg_descr)--    -- If the user wanted to save the config, write it back-    traverse_ (writePersistBuildConfig distPref) maybeConfig--  where-        removeFileOrDirectory :: FilePath -> IO ()-        removeFileOrDirectory fname = do-            isDir <- doesDirectoryExist fname-            isFile <- doesFileExist fname-            if isDir then removeDirectoryRecursive fname-              else when isFile $ removeFile fname-        verbosity = fromFlag (cleanVerbosity flags)---- ----------------------------------------------------------------------------- Default hooks---- | Hooks that correspond to a plain instantiation of the--- \"simple\" build system-simpleUserHooks :: UserHooks-simpleUserHooks =-    emptyUserHooks {-       confHook  = configure,-       postConf  = finalChecks,-       buildHook = defaultBuildHook,-       replHook  = defaultReplHook,-       copyHook  = \desc lbi _ f -> install desc lbi f,-                   -- 'install' has correct 'copy' behavior with params-       testHook  = defaultTestHook,-       benchHook = defaultBenchHook,-       instHook  = defaultInstallHook,-       cleanHook = \p _ _ f -> clean p f,-       hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f,-       haddockHook  = \p l h f -> haddock  p l (allSuffixHandlers h) f,-       regHook   = defaultRegHook,-       unregHook = \p l _ f -> unregister p l f-      }-  where-    finalChecks _args flags pkg_descr lbi =-      checkForeignDeps pkg_descr lbi (lessVerbose verbosity)-      where-        verbosity = fromFlag (configVerbosity flags)---- | Basic autoconf 'UserHooks':------ * 'postConf' runs @.\/configure@, if present.------ * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst',---   'preReg' and 'preUnreg' read additional build information from---   /package/@.buildinfo@, if present.------ Thus @configure@ can use local system information to generate--- /package/@.buildinfo@ and possibly other files.--autoconfUserHooks :: UserHooks-autoconfUserHooks-    = simpleUserHooks-      {-       postConf    = defaultPostConf,-       preBuild    = readHookWithArgs buildVerbosity buildDistPref, -- buildCabalFilePath,-       preCopy     = readHookWithArgs copyVerbosity copyDistPref,-       preClean    = readHook cleanVerbosity cleanDistPref,-       preInst     = readHook installVerbosity installDistPref,-       preHscolour = readHook hscolourVerbosity hscolourDistPref,-       preHaddock  = readHookWithArgs haddockVerbosity haddockDistPref,-       preReg      = readHook regVerbosity regDistPref,-       preUnreg    = readHook regVerbosity regDistPref-      }-    where defaultPostConf :: Args -> ConfigFlags -> PackageDescription-                          -> LocalBuildInfo -> IO ()-          defaultPostConf args flags pkg_descr lbi-              = do let verbosity = fromFlag (configVerbosity flags)-                       baseDir lbi' = fromMaybe ""-                                      (takeDirectory <$> cabalFilePath lbi')-                   confExists <- doesFileExist $ (baseDir lbi) </> "configure"-                   if confExists-                     then runConfigureScript verbosity-                            backwardsCompatHack flags lbi-                     else die' verbosity "configure script not found."--                   pbi <- getHookedBuildInfo verbosity (buildDir lbi)-                   sanityCheckHookedBuildInfo verbosity pkg_descr pbi-                   let pkg_descr' = updatePackageDescription pbi pkg_descr-                       lbi' = lbi { localPkgDescr = pkg_descr' }-                   postConf simpleUserHooks args flags pkg_descr' lbi'--          backwardsCompatHack = False--          readHookWithArgs :: (a -> Flag Verbosity)-                           -> (a -> Flag FilePath)-                           -> Args -> a-                           -> IO HookedBuildInfo-          readHookWithArgs get_verbosity get_dist_pref _ flags = do-              dist_dir <- findDistPrefOrDefault (get_dist_pref flags)-              getHookedBuildInfo verbosity (dist_dir </> "build")-            where-              verbosity = fromFlag (get_verbosity flags)--          readHook :: (a -> Flag Verbosity)-                   -> (a -> Flag FilePath)-                   -> Args -> a -> IO HookedBuildInfo-          readHook get_verbosity get_dist_pref a flags = do-              noExtraFlags a-              dist_dir <- findDistPrefOrDefault (get_dist_pref flags)-              getHookedBuildInfo verbosity (dist_dir </> "build")-            where-              verbosity = fromFlag (get_verbosity flags)--runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo-                   -> IO ()-runConfigureScript verbosity backwardsCompatHack flags lbi = do-  env <- getEnvironment-  let programDb = withPrograms lbi-  (ccProg, ccFlags) <- configureCCompiler verbosity programDb-  ccProgShort <- getShortPathName ccProg-  -- The C compiler's compilation and linker flags (e.g.-  -- "C compiler flags" and "Gcc Linker flags" from GHC) have already-  -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS-  -- to ccFlags-  -- We don't try and tell configure which ld to use, as we don't have-  -- a way to pass its flags too-  configureFile <- makeAbsolute $-    fromMaybe "." (takeDirectory <$> cabalFilePath lbi) </> "configure"-  -- autoconf is fussy about filenames, and has a set of forbidden-  -- characters that can't appear in the build directory, etc:-  -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions-  ---  -- This has caused hard-to-debug failures in the past (#5368), so we-  -- detect some cases early and warn with a clear message. Windows's-  -- use of backslashes is problematic here, so we'll switch to-  -- slashes, but we do still want to fail on backslashes in POSIX-  -- paths.-  ---  -- TODO: We don't check for colons, tildes or leading dashes. We-  -- also should check the builddir's path, destdir, and all other-  -- paths as well.-  let configureFile' = toUnix configureFile-  for_ badAutoconfCharacters $ \(c, cname) ->-    when (c `elem` dropDrive configureFile') $-      warn verbosity $ concat-        [ "The path to the './configure' script, '", configureFile'-        , "', contains the character '", [c], "' (", cname, ")."-        , " This may cause the script to fail with an obscure error, or for"-        , " building the package to fail later."-        ]--  let extraPath = fromNubList $ configProgramPathExtra flags-  let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags))-                  $ lookup "CFLAGS" env-      spSep = [searchPathSeparator]-      pathEnv = maybe (intercalate spSep extraPath)-                ((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env-      overEnv = ("CFLAGS", Just cflagsEnv) :-                [("PATH", Just pathEnv) | not (null extraPath)]-      hp = hostPlatform lbi-      maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)]-      args' = configureFile':args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag-      shProg = simpleProgram "sh"-      progDb = modifyProgramSearchPath-               (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb-  shConfiguredProg <- lookupProgram shProg-                      `fmap` configureProgram  verbosity shProg progDb-  case shConfiguredProg of-      Just sh -> runProgramInvocation verbosity $-                 (programInvocation (sh {programOverrideEnv = overEnv}) args')-                 { progInvokeCwd = Just (buildDir lbi) }-      Nothing -> die' verbosity notFoundMsg-  where-    args = configureArgs backwardsCompatHack flags--    notFoundMsg = "The package has a './configure' script. "-               ++ "If you are on Windows, This requires a "-               ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. "-               ++ "If you are not on Windows, ensure that an 'sh' command "-               ++ "is discoverable in your path."---- | Convert Windows path to Unix ones-toUnix :: String -> String-#ifdef mingw32_HOST_OS-toUnix s = let tmp = normalise s-               (l, rest) = case splitDrive tmp of-                             ([],  x) -> ("/"      , x)-                             (h:_, x) -> ('/':h:"/", x)-               parts = splitDirectories rest-           in  l ++ intercalate "/" parts-#else-toUnix s = intercalate "/" $ splitDirectories s-#endif--badAutoconfCharacters :: [(Char, String)]-badAutoconfCharacters =-  [ (' ', "space")-  , ('\t', "tab")-  , ('\n', "newline")-  , ('\0', "null")-  , ('"', "double quote")-  , ('#', "hash")-  , ('$', "dollar sign")-  , ('&', "ampersand")-  , ('\'', "single quote")-  , ('(', "left bracket")-  , (')', "right bracket")-  , ('*', "star")-  , (';', "semicolon")-  , ('<', "less-than sign")-  , ('=', "equals sign")-  , ('>', "greater-than sign")-  , ('?', "question mark")-  , ('[', "left square bracket")-  , ('\\', "backslash")-  , ('`', "backtick")-  , ('|', "pipe")-  ]--getHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo-getHookedBuildInfo verbosity build_dir = do-  maybe_infoFile <- findHookedPackageDesc verbosity build_dir-  case maybe_infoFile of-    Nothing       -> return emptyHookedBuildInfo-    Just infoFile -> do-      info verbosity $ "Reading parameters from " ++ infoFile-      readHookedBuildInfo verbosity infoFile--defaultTestHook :: Args -> PackageDescription -> LocalBuildInfo-                -> UserHooks -> TestFlags -> IO ()-defaultTestHook args pkg_descr localbuildinfo _ flags =-    test args pkg_descr localbuildinfo flags--defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo-                 -> UserHooks -> BenchmarkFlags -> IO ()-defaultBenchHook args pkg_descr localbuildinfo _ flags =-    bench args pkg_descr localbuildinfo flags--defaultInstallHook :: PackageDescription -> LocalBuildInfo-                   -> UserHooks -> InstallFlags -> IO ()-defaultInstallHook pkg_descr localbuildinfo _ flags = do-  let copyFlags = defaultCopyFlags {-                      copyDistPref   = installDistPref flags,-                      copyDest       = installDest     flags,-                      copyVerbosity  = installVerbosity flags-                  }-  install pkg_descr localbuildinfo copyFlags-  let registerFlags = defaultRegisterFlags {-                          regDistPref  = installDistPref flags,-                          regInPlace   = installInPlace flags,-                          regPackageDB = installPackageDB flags,-                          regVerbosity = installVerbosity flags-                      }-  when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags--defaultBuildHook :: PackageDescription -> LocalBuildInfo-        -> UserHooks -> BuildFlags -> IO ()-defaultBuildHook pkg_descr localbuildinfo hooks flags =-  build pkg_descr localbuildinfo flags (allSuffixHandlers hooks)--defaultReplHook :: PackageDescription -> LocalBuildInfo-        -> UserHooks -> ReplFlags -> [String] -> IO ()-defaultReplHook pkg_descr localbuildinfo hooks flags args =-  repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args--defaultRegHook :: PackageDescription -> LocalBuildInfo-        -> UserHooks -> RegisterFlags -> IO ()-defaultRegHook pkg_descr localbuildinfo _ flags =-    if hasLibs pkg_descr-    then register pkg_descr localbuildinfo flags-    else setupMessage (fromFlag (regVerbosity flags))-           "Package contains no library to register:" (packageId pkg_descr)+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+{-+Work around this warning:+libraries/Cabal/Distribution/Simple.hs:78:0:+    Warning: In the use of `runTests'+             (imported from Distribution.Simple.UserHooks):+             Deprecated: "Please use the new testing interface instead!"+-}+{-# OPTIONS_GHC -Wno-deprecations #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- |+-- Module      :  Distribution.Simple+-- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This is the command line front end to the Simple build system. When given+-- the parsed command-line args and package information, is able to perform+-- basic commands like configure, build, install, register, etc.+--+-- This module exports the main functions that Setup.hs scripts use. It+-- re-exports the 'UserHooks' type, the standard entry points like+-- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of+-- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own+-- behaviour.+--+-- This module isn't called \"Simple\" because it's simple.  Far from+-- it.  It's called \"Simple\" because it does complicated things to+-- 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.+module Distribution.Simple+  ( module Distribution.Package+  , module Distribution.Version+  , module Distribution.License+  , module Distribution.Simple.Compiler+  , module Language.Haskell.Extension++    -- * Simple interface+  , defaultMain+  , defaultMainNoRead+  , defaultMainArgs++    -- * Customization+  , UserHooks (..)+  , Args+  , defaultMainWithHooks+  , defaultMainWithSetupHooks+  , defaultMainWithSetupHooksArgs+  , defaultMainWithHooksArgs+  , defaultMainWithHooksNoRead+  , defaultMainWithHooksNoReadArgs++    -- ** Standard sets of hooks+  , simpleUserHooks+  , autoconfUserHooks+  , autoconfSetupHooks+  , emptyUserHooks+  ) where++import Control.Exception (try)++import Distribution.Compat.Prelude+import Distribution.Compat.ResponseFile (expandResponse)+import Prelude ()++-- local++import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Configuration+import Distribution.Simple.Command+import Distribution.Simple.Compiler+import Distribution.Simple.PackageDescription+import Distribution.Simple.PreProcess+import Distribution.Simple.Program+import Distribution.Simple.Setup+import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks+import Distribution.Simple.UserHooks++import Distribution.Simple.Build+import Distribution.Simple.Register+import Distribution.Simple.SrcDist++import Distribution.Simple.Configure++import Distribution.License+import Distribution.Pretty+import Distribution.Simple.Bench+import Distribution.Simple.BuildPaths+import Distribution.Simple.ConfigureScript (runConfigureScript)+import Distribution.Simple.Errors+import Distribution.Simple.Haddock+import Distribution.Simple.Install+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.SetupHooks.Internal+  ( SetupHooks+  )+import Distribution.Simple.Test+import Distribution.Simple.Utils+import qualified Distribution.Types.LocalBuildConfig as LBC+import Distribution.Utils.Path+import Distribution.Verbosity+import Distribution.Version+import Language.Haskell.Extension++-- Base+import Data.List (unionBy, (\\))+import System.Directory+  ( doesDirectoryExist+  , doesFileExist+  , removeDirectoryRecursive+  , removeFile+  )+import System.Environment (getArgs, getProgName)++-- | A simple implementation of @main@ for a Cabal setup script.+-- It reads the package description file using IO, and performs the+-- action specified on the command line.+defaultMain :: IO ()+defaultMain = getArgs >>= defaultMainHelper simpleUserHooks++-- | A version of 'defaultMain' that is passed the command line+-- arguments, rather than getting them from the environment.+defaultMainArgs :: [String] -> IO ()+defaultMainArgs = defaultMainHelper simpleUserHooks++defaultMainWithSetupHooks :: SetupHooks -> IO ()+defaultMainWithSetupHooks setup_hooks =+  getArgs >>= defaultMainWithSetupHooksArgs setup_hooks++defaultMainWithSetupHooksArgs :: SetupHooks -> [String] -> IO ()+defaultMainWithSetupHooksArgs setupHooks =+  defaultMainHelper $+    simpleUserHooks+      { confHook = setup_confHook+      , buildHook = setup_buildHook+      , copyHook = setup_copyHook+      , instHook = setup_installHook+      , replHook = setup_replHook+      , haddockHook = setup_haddockHook+      , hscolourHook = setup_hscolourHook+      }+  where+    setup_confHook+      :: (GenericPackageDescription, HookedBuildInfo)+      -> ConfigFlags+      -> IO LocalBuildInfo+    setup_confHook =+      configure_setupHooks+        (SetupHooks.configureHooks setupHooks)++    setup_buildHook+      :: PackageDescription+      -> LocalBuildInfo+      -> UserHooks+      -> BuildFlags+      -> IO ()+    setup_buildHook pkg_descr lbi hooks flags =+      build_setupHooks+        (SetupHooks.buildHooks setupHooks)+        pkg_descr+        lbi+        flags+        (allSuffixHandlers hooks)++    setup_copyHook+      :: PackageDescription+      -> LocalBuildInfo+      -> UserHooks+      -> CopyFlags+      -> IO ()+    setup_copyHook pkg_descr lbi _hooks flags =+      install_setupHooks+        (SetupHooks.installHooks setupHooks)+        pkg_descr+        lbi+        flags++    setup_installHook+      :: PackageDescription+      -> LocalBuildInfo+      -> UserHooks+      -> InstallFlags+      -> IO ()+    setup_installHook =+      defaultInstallHook_setupHooks+        (SetupHooks.installHooks setupHooks)++    setup_replHook+      :: PackageDescription+      -> LocalBuildInfo+      -> UserHooks+      -> ReplFlags+      -> [String]+      -> IO ()+    setup_replHook pkg_descr lbi hooks flags args =+      repl_setupHooks+        (SetupHooks.buildHooks setupHooks)+        pkg_descr+        lbi+        flags+        (allSuffixHandlers hooks)+        args++    setup_haddockHook+      :: PackageDescription+      -> LocalBuildInfo+      -> UserHooks+      -> HaddockFlags+      -> IO ()+    setup_haddockHook pkg_descr lbi hooks flags =+      haddock_setupHooks+        (SetupHooks.buildHooks setupHooks)+        pkg_descr+        lbi+        (allSuffixHandlers hooks)+        flags++    setup_hscolourHook+      :: PackageDescription+      -> LocalBuildInfo+      -> UserHooks+      -> HscolourFlags+      -> IO ()+    setup_hscolourHook pkg_descr lbi hooks flags =+      hscolour_setupHooks+        (SetupHooks.buildHooks setupHooks)+        pkg_descr+        lbi+        (allSuffixHandlers hooks)+        flags++-- | A customizable version of 'defaultMain'.+defaultMainWithHooks :: UserHooks -> IO ()+defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks++-- | A customizable version of 'defaultMain' that also takes the command+-- line arguments.+defaultMainWithHooksArgs :: UserHooks -> [String] -> IO ()+defaultMainWithHooksArgs = defaultMainHelper++-- | Like 'defaultMain', but accepts the package description as input+-- rather than using IO to read it.+defaultMainNoRead :: GenericPackageDescription -> IO ()+defaultMainNoRead = defaultMainWithHooksNoRead simpleUserHooks++-- | A customizable version of 'defaultMainNoRead'.+defaultMainWithHooksNoRead :: UserHooks -> GenericPackageDescription -> IO ()+defaultMainWithHooksNoRead hooks pkg_descr =+  getArgs+    >>= defaultMainHelper hooks{readDesc = return (Just pkg_descr)}++-- | A customizable version of 'defaultMainNoRead' that also takes the+-- command line arguments.+--+-- @since 2.2.0.0+defaultMainWithHooksNoReadArgs :: UserHooks -> GenericPackageDescription -> [String] -> IO ()+defaultMainWithHooksNoReadArgs hooks pkg_descr =+  defaultMainHelper hooks{readDesc = return (Just pkg_descr)}++-- | The central command chooser of the Simple build system,+-- with other defaultMain functions acting as exposed callers,+-- and with 'topHandler' operating as an exceptions handler.+--+-- This uses 'expandResponse' to read response files, preprocessing+-- response files given by "@" prefixes.+--+-- Given hooks and args, this runs 'commandsRun' onto the args,+-- 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+  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 = addKnownPrograms (hookedPrograms hooks) defaultProgramDb+    addAction :: CommandUI flags -> (GlobalFlags -> UserHooks -> flags -> [String] -> IO res) -> Command (GlobalFlags -> IO ())+    addAction cmd action =+      cmd `commandAddAction` \flags as globalFlags -> void $ action globalFlags hooks flags as+    commands :: [Command (GlobalFlags -> IO ())]+    commands =+      [ configureCommand progs `addAction` configureAction+      , buildCommand progs `addAction` buildAction+      , replCommand progs `addAction` replAction+      , installCommand `addAction` installAction+      , copyCommand `addAction` copyAction+      , haddockCommand `addAction` haddockAction+      , cleanCommand `addAction` cleanAction+      , sdistCommand `addAction` sdistAction+      , hscolourCommand `addAction` hscolourAction+      , registerCommand `addAction` registerAction+      , unregisterCommand `addAction` unregisterAction+      , testCommand `addAction` testAction+      , benchmarkCommand `addAction` benchAction+      ]++-- | Combine the preprocessors in the given hooks with the+-- preprocessors built into cabal.+allSuffixHandlers+  :: UserHooks+  -> [PPSuffixHandler]+allSuffixHandlers hooks =+  overridesPP (hookedPreProcessors hooks) knownSuffixHandlers+  where+    overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler]+    overridesPP = unionBy (\x y -> fst x == fst y)++configureAction :: GlobalFlags -> UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo+configureAction globalFlags hooks flags args = do+  distPref <- findDistPrefOrDefault (setupDistPref $ configCommonFlags flags)+  let commonFlags = configCommonFlags flags+      commonFlags' =+        commonFlags+          { setupDistPref = toFlag distPref+          , setupWorkingDir = globalWorkingDir globalFlags <> setupWorkingDir commonFlags+          , setupTargets = args+          }+      flags' =+        flags+          { configCommonFlags = commonFlags'+          }+      mbWorkDir = flagToMaybe $ setupWorkingDir commonFlags'+      verbosity = fromFlag $ setupVerbosity commonFlags'++  -- See docs for 'HookedBuildInfo'+  pbi <- preConf hooks args flags'++  (mb_pd_file, pkg_descr0) <-+    confPkgDescr+      hooks+      verbosity+      mbWorkDir+      (flagToMaybe (setupCabalFilePath commonFlags'))++  let epkg_descr = (pkg_descr0, pbi)++  lbi1 <- confHook hooks epkg_descr flags'++  -- remember the .cabal filename if we know it+  -- and all the extra command line args+  let localbuildinfo =+        lbi1+          { pkgDescrFile = mb_pd_file+          , extraConfigArgs = args+          }+  writePersistBuildConfig mbWorkDir distPref localbuildinfo++  let pkg_descr = localPkgDescr localbuildinfo+  postConf hooks args flags' pkg_descr localbuildinfo+  return localbuildinfo++confPkgDescr+  :: UserHooks+  -> Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> Maybe (SymbolicPath Pkg File)+  -> IO (Maybe (SymbolicPath Pkg File), GenericPackageDescription)+confPkgDescr hooks verbosity cwd mb_path = do+  mdescr <- readDesc hooks+  case mdescr of+    Just descr -> return (Nothing, descr)+    Nothing -> do+      pdfile <- case mb_path of+        Nothing -> relativeSymbolicPath <$> tryFindPackageDesc verbosity cwd+        Just path -> return path+      info verbosity "Using Parsec parser"+      descr <- readGenericPackageDescription verbosity cwd pdfile+      return (Just pdfile, descr)++getCommonFlags+  :: GlobalFlags+  -> UserHooks+  -> CommonSetupFlags+  -> Args+  -> IO (LocalBuildInfo, CommonSetupFlags)+getCommonFlags globalFlags hooks commonFlags args = do+  distPref <- findDistPrefOrDefault (setupDistPref commonFlags)+  let verbosity = fromFlag $ setupVerbosity commonFlags+  lbi <- getBuildConfig globalFlags hooks verbosity distPref+  let common' = configCommonFlags $ configFlags lbi+  return $+    ( lbi+    , commonFlags+        { setupDistPref = toFlag distPref+        , setupCabalFilePath = setupCabalFilePath common' <> setupCabalFilePath commonFlags+        , setupWorkingDir =+            globalWorkingDir globalFlags+              <> setupWorkingDir common'+              <> setupWorkingDir commonFlags+        , setupTargets = args+        }+    )++buildAction :: GlobalFlags -> UserHooks -> BuildFlags -> Args -> IO ()+buildAction globalFlags hooks flags args = do+  let common = buildCommonFlags flags+      verbosity = fromFlag $ setupVerbosity common+  (lbi, common') <- getCommonFlags globalFlags hooks common args+  let flags' = flags{buildCommonFlags = common'}++  progs <-+    reconfigurePrograms+      verbosity+      (buildProgramPaths flags')+      (buildProgramArgs flags')+      (withPrograms lbi)++  hookedAction+    verbosity+    preBuild+    buildHook+    postBuild+    (return lbi{withPrograms = progs})+    hooks+    flags'+    args++replAction :: GlobalFlags -> UserHooks -> ReplFlags -> Args -> IO ()+replAction globalFlags hooks flags args = do+  let common = replCommonFlags flags+      verbosity = fromFlag $ setupVerbosity common+  (lbi, common') <- getCommonFlags globalFlags hooks common args+  let flags' = flags{replCommonFlags = common'}+  progs <-+    reconfigurePrograms+      verbosity+      (replProgramPaths flags')+      (replProgramArgs flags')+      (withPrograms lbi)++  -- As far as I can tell, the only reason this doesn't use+  -- 'hookedActionWithArgs' is because the arguments of 'replHook'+  -- takes the args explicitly.  UGH.   -- ezyang+  pbi <- preRepl hooks args flags'+  let pkg_descr0 = localPkgDescr lbi+  sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi+  let pkg_descr = updatePackageDescription pbi pkg_descr0+      lbi' =+        lbi+          { withPrograms = progs+          , localPkgDescr = pkg_descr+          }+  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+  let common = hscolourCommonFlags flags+      verbosity = fromFlag $ setupVerbosity common+  (_lbi, common') <- getCommonFlags globalFlags hooks common args+  let flags' = flags{hscolourCommonFlags = common'}+      distPref = fromFlag $ setupDistPref common'++  hookedAction+    verbosity+    preHscolour+    hscolourHook+    postHscolour+    (getBuildConfig globalFlags hooks verbosity distPref)+    hooks+    flags'+    args++haddockAction :: GlobalFlags -> UserHooks -> HaddockFlags -> Args -> IO ()+haddockAction globalFlags hooks flags args = do+  let common = haddockCommonFlags flags+      verbosity = fromFlag $ setupVerbosity common+  (lbi, common') <- getCommonFlags globalFlags hooks common args+  let flags' = flags{haddockCommonFlags = common'}++  progs <-+    reconfigurePrograms+      verbosity+      (haddockProgramPaths flags')+      (haddockProgramArgs flags')+      (withPrograms lbi)++  hookedAction+    verbosity+    preHaddock+    haddockHook+    postHaddock+    (return lbi{withPrograms = progs})+    hooks+    flags'+    args++cleanAction :: GlobalFlags -> UserHooks -> CleanFlags -> Args -> IO ()+cleanAction globalFlags hooks flags args = do+  let common = cleanCommonFlags flags+      verbosity = fromFlag $ setupVerbosity common+  distPref <- findDistPrefOrDefault (setupDistPref common)+  elbi <- tryGetBuildConfig globalFlags hooks verbosity distPref+  let common' =+        common+          { setupDistPref = toFlag distPref+          , setupWorkingDir = case elbi of+              Left _ ->+                globalWorkingDir globalFlags+                  <> setupWorkingDir common+              Right lbi ->+                globalWorkingDir globalFlags+                  <> setupWorkingDir (configCommonFlags $ configFlags lbi)+                  <> setupWorkingDir common+          , setupCabalFilePath = case elbi of+              Left _ -> setupCabalFilePath common+              Right lbi ->+                setupCabalFilePath common+                  <> setupCabalFilePath (configCommonFlags $ configFlags lbi)+          , setupTargets = args+          }+      flags' =+        flags{cleanCommonFlags = common'}++      mbWorkDirFlag = cleanWorkingDir flags'+      mbWorkDir = flagToMaybe mbWorkDirFlag++  pbi <- preClean hooks args flags'++  (_, ppd) <- confPkgDescr hooks verbosity mbWorkDir Nothing+  -- It might seem like we are doing something clever here+  -- but we're really not: if you look at the implementation+  -- of 'clean' in the end all the package description is+  -- used for is to clear out @extra-tmp-files@.  IMO,+  -- the configure script goo should go into @dist@ too!+  --          -- ezyang+  let pkg_descr0 = flattenPackageDescription ppd+  -- We don't sanity check for clean as an error+  -- here would prevent cleaning:+  -- sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi+  let pkg_descr = updatePackageDescription pbi pkg_descr0++  cleanHook hooks pkg_descr () hooks flags'+  postClean hooks args flags' pkg_descr ()++copyAction :: GlobalFlags -> UserHooks -> CopyFlags -> Args -> IO ()+copyAction globalFlags hooks flags args = do+  let common = copyCommonFlags flags+      verbosity = fromFlag $ setupVerbosity common+  (_lbi, common') <- getCommonFlags globalFlags hooks common args+  let flags' = flags{copyCommonFlags = common'}+      distPref = fromFlag $ setupDistPref common'+  hookedAction+    verbosity+    preCopy+    copyHook+    postCopy+    (getBuildConfig globalFlags hooks verbosity distPref)+    hooks+    flags'+    args++installAction :: GlobalFlags -> UserHooks -> InstallFlags -> Args -> IO ()+installAction globalFlags hooks flags args = do+  let common = installCommonFlags flags+      verbosity = fromFlag $ setupVerbosity common+  (_lbi, common') <- getCommonFlags globalFlags hooks common args+  let flags' = flags{installCommonFlags = common'}+      distPref = fromFlag $ setupDistPref common'+  hookedAction+    verbosity+    preInst+    instHook+    postInst+    (getBuildConfig globalFlags hooks verbosity distPref)+    hooks+    flags'+    args++-- Since Cabal-3.4 UserHooks are completely ignored+sdistAction :: GlobalFlags -> UserHooks -> SDistFlags -> Args -> IO ()+sdistAction _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+  where+    verbosity = fromFlag (setupVerbosity $ sDistCommonFlags flags)++testAction :: GlobalFlags -> UserHooks -> TestFlags -> Args -> IO ()+testAction globalFlags hooks flags args = do+  let common = testCommonFlags flags+      verbosity = fromFlag $ setupVerbosity common+  (_lbi, common') <- getCommonFlags globalFlags hooks common args+  let flags' = flags{testCommonFlags = common'}+      distPref = fromFlag $ setupDistPref common'+  hookedActionWithArgs+    verbosity+    preTest+    testHook+    postTest+    (getBuildConfig globalFlags hooks verbosity distPref)+    hooks+    flags'+    args++benchAction :: GlobalFlags -> UserHooks -> BenchmarkFlags -> Args -> IO ()+benchAction globalFlags hooks flags args = do+  let common = benchmarkCommonFlags flags+      verbosity = fromFlag $ setupVerbosity common+  (_lbi, common') <- getCommonFlags globalFlags hooks common args+  let flags' = flags{benchmarkCommonFlags = common'}+      distPref = fromFlag $ setupDistPref common'+  hookedActionWithArgs+    verbosity+    preBench+    benchHook+    postBench+    (getBuildConfig globalFlags hooks verbosity distPref)+    hooks+    flags'+    args++registerAction :: GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO ()+registerAction globalFlags hooks flags args = do+  let common = registerCommonFlags flags+      verbosity = fromFlag $ setupVerbosity common+  (_lbi, common') <- getCommonFlags globalFlags hooks common args+  let flags' = flags{registerCommonFlags = common'}+      distPref = fromFlag $ setupDistPref common'+  hookedAction+    verbosity+    preReg+    regHook+    postReg+    (getBuildConfig globalFlags hooks verbosity distPref)+    hooks+    flags'+    args++unregisterAction :: GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO ()+unregisterAction globalFlags hooks flags args = do+  let common = registerCommonFlags flags+      verbosity = fromFlag $ setupVerbosity common+  (_lbi, common') <- getCommonFlags globalFlags hooks common args+  let flags' = flags{registerCommonFlags = common'}+      distPref = fromFlag $ setupDistPref common'+  hookedAction+    verbosity+    preUnreg+    unregHook+    postUnreg+    (getBuildConfig globalFlags hooks verbosity distPref)+    hooks+    flags'+    args++hookedAction+  :: Verbosity+  -> (UserHooks -> Args -> flags -> IO HookedBuildInfo)+  -> ( UserHooks+       -> PackageDescription+       -> LocalBuildInfo+       -> UserHooks+       -> flags+       -> IO ()+     )+  -> ( UserHooks+       -> Args+       -> flags+       -> PackageDescription+       -> LocalBuildInfo+       -> IO ()+     )+  -> IO LocalBuildInfo+  -> UserHooks+  -> flags+  -> Args+  -> IO ()+hookedAction verbosity pre_hook cmd_hook =+  hookedActionWithArgs+    verbosity+    pre_hook+    ( \h _ pd lbi uh flags ->+        cmd_hook h pd lbi uh flags+    )++hookedActionWithArgs+  :: Verbosity+  -> (UserHooks -> Args -> flags -> IO HookedBuildInfo)+  -> ( UserHooks+       -> Args+       -> PackageDescription+       -> LocalBuildInfo+       -> UserHooks+       -> flags+       -> IO ()+     )+  -> ( UserHooks+       -> Args+       -> flags+       -> PackageDescription+       -> LocalBuildInfo+       -> IO ()+     )+  -> IO LocalBuildInfo+  -> UserHooks+  -> flags+  -> Args+  -> IO ()+hookedActionWithArgs+  verbosity+  pre_hook+  cmd_hook+  post_hook+  get_build_config+  hooks+  flags+  args = do+    pbi <- pre_hook hooks args flags+    lbi0 <- get_build_config+    let pkg_descr0 = localPkgDescr lbi0+    sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi+    let pkg_descr = updatePackageDescription pbi pkg_descr0+        lbi = lbi0{localPkgDescr = pkg_descr}+    cmd_hook hooks args pkg_descr lbi hooks flags+    post_hook hooks args flags pkg_descr lbi++sanityCheckHookedBuildInfo+  :: Verbosity -> PackageDescription -> HookedBuildInfo -> IO ()+sanityCheckHookedBuildInfo+  verbosity+  (PackageDescription{library = Nothing})+  (Just _, _) =+    dieWithException verbosity $ NoLibraryForPackage+sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes)+  | exe1 : _ <- nonExistant =+      dieWithException verbosity $ SanityCheckHookedBuildInfo exe1+  where+    pkgExeNames = nub (map exeName (executables pkg_descr))+    hookExeNames = nub (map fst hookExes)+    nonExistant = hookExeNames \\ pkgExeNames+sanityCheckHookedBuildInfo _ _ _ = return ()++-- | Try to read the 'localBuildInfoFile'+tryGetBuildConfig+  :: GlobalFlags+  -> UserHooks+  -> Verbosity+  -> SymbolicPath Pkg (Dir Dist)+  -> IO (Either ConfigStateFileError LocalBuildInfo)+tryGetBuildConfig g u v = try . getBuildConfig g u v++-- | Read the 'localBuildInfoFile' or throw an exception.+getBuildConfig+  :: GlobalFlags+  -> UserHooks+  -> Verbosity+  -> SymbolicPath Pkg (Dir Dist)+  -> IO LocalBuildInfo+getBuildConfig globalFlags hooks verbosity distPref = do+  lbi_wo_programs <- getPersistBuildConfig mbWorkDir distPref+  -- Restore info about unconfigured programs, since it is not serialized+  let lbi =+        lbi_wo_programs+          { withPrograms =+              restoreProgramDb+                (builtinPrograms ++ hookedPrograms hooks)+                (withPrograms lbi_wo_programs)+          }++  case pkgDescrFile lbi of+    Nothing -> return lbi+    Just pkg_descr_file -> do+      outdated <- checkPersistBuildConfigOutdated mbWorkDir distPref pkg_descr_file+      if outdated+        then reconfigure pkg_descr_file lbi+        else return lbi+  where+    mbWorkDir = flagToMaybe $ globalWorkingDir globalFlags+    reconfigure :: SymbolicPath Pkg File -> LocalBuildInfo -> IO LocalBuildInfo+    reconfigure pkg_descr_file lbi = do+      notice verbosity $+        getSymbolicPath pkg_descr_file+          ++ " has been changed. "+          ++ "Re-configuring with most recently used options. "+          ++ "If this fails, please run configure manually.\n"+      let cFlags = configFlags lbi+      let cFlags' =+            cFlags+              { -- Since the list of unconfigured programs is not serialized,+                -- restore it to the same value as normally used at the beginning+                -- of a configure run:+                configPrograms_ =+                  fmap+                    ( restoreProgramDb+                        (builtinPrograms ++ hookedPrograms hooks)+                    )+                    `fmap` configPrograms_ cFlags+              , configCommonFlags =+                  (configCommonFlags cFlags)+                    { -- Use the current, not saved verbosity level:+                      setupVerbosity = Flag verbosity+                    }+              }+      configureAction globalFlags hooks cFlags' (extraConfigArgs lbi)++-- --------------------------------------------------------------------------+-- Cleaning++clean :: PackageDescription -> CleanFlags -> IO ()+clean pkg_descr flags = do+  let common = cleanCommonFlags flags+      verbosity = fromFlag (setupVerbosity common)+      distPref = fromFlagOrDefault defaultDistPref $ setupDistPref common+      mbWorkDir = flagToMaybe $ setupWorkingDir common+      i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path+      distPath = i distPref+  notice verbosity "cleaning..."++  maybeConfig <-+    if fromFlag (cleanSaveConf flags)+      then maybeGetPersistBuildConfig mbWorkDir distPref+      else return Nothing++  -- remove the whole dist/ directory rather than tracking exactly what files+  -- we created in there.+  chattyTry "removing dist/" $ do+    exists <- doesDirectoryExist distPath+    when exists (removeDirectoryRecursive distPath)++  -- Any extra files the user wants to remove+  traverse_ (removeFileOrDirectory . 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++-- | Hooks that correspond to a plain instantiation of the+-- \"simple\" build system+simpleUserHooks :: UserHooks+simpleUserHooks =+  emptyUserHooks+    { confHook = configure+    , postConf = finalChecks+    , buildHook = defaultBuildHook+    , replHook = defaultReplHook+    , copyHook = \desc lbi _ f -> install desc lbi f+    , -- 'install' has correct 'copy' behavior with params+      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+    }+  where+    finalChecks _args flags pkg_descr lbi =+      checkForeignDeps pkg_descr lbi (lessVerbose verbosity)+      where+        verbosity = fromFlag (setupVerbosity $ configCommonFlags flags)++-- | Basic autoconf 'UserHooks':+--+-- * 'postConf' runs @.\/configure@, if present.+--+-- * the pre-hooks, except for pre-conf, read additional build information from+--   /package/@.buildinfo@, if present.+--+-- Thus @configure@ can use local system information to generate+-- /package/@.buildinfo@ and possibly other files.+autoconfUserHooks :: UserHooks+autoconfUserHooks =+  simpleUserHooks+    { postConf = defaultPostConf+    , preBuild = readHookWithArgs buildCommonFlags+    , preRepl = readHookWithArgs replCommonFlags+    , preCopy = readHookWithArgs copyCommonFlags+    , preClean = readHook cleanCommonFlags+    , preInst = readHook installCommonFlags+    , preHscolour = readHook hscolourCommonFlags+    , preHaddock = readHookWithArgs haddockCommonFlags+    , preReg = readHook registerCommonFlags+    , preUnreg = readHook registerCommonFlags+    , preTest = readHookWithArgs testCommonFlags+    , preBench = readHookWithArgs benchmarkCommonFlags+    }+  where+    defaultPostConf+      :: Args+      -> ConfigFlags+      -> PackageDescription+      -> LocalBuildInfo+      -> IO ()+    defaultPostConf args flags pkg_descr lbi =+      do+        let common = configCommonFlags flags+            verbosity = fromFlag $ setupVerbosity common+            mbWorkDir = flagToMaybe $ setupWorkingDir common+        runConfigureScript+          flags+          (flagAssignment lbi)+          (withPrograms lbi)+          (hostPlatform lbi)+        pbi <- getHookedBuildInfo verbosity mbWorkDir (buildDir lbi)+        sanityCheckHookedBuildInfo verbosity pkg_descr pbi+        let pkg_descr' = updatePackageDescription pbi pkg_descr+            lbi' = lbi{localPkgDescr = pkg_descr'}+        postConf simpleUserHooks args flags pkg_descr' lbi'++    readHookWithArgs+      :: (flags -> CommonSetupFlags)+      -> Args+      -> flags+      -> IO HookedBuildInfo+    readHookWithArgs get_common_flags _args flags = do+      let common = get_common_flags flags+          verbosity = fromFlag (setupVerbosity common)+          mbWorkDir = flagToMaybe $ setupWorkingDir common+          distPref = setupDistPref common+      dist_dir <- findDistPrefOrDefault distPref+      getHookedBuildInfo verbosity mbWorkDir (dist_dir </> makeRelativePathEx "build")++    readHook+      :: (flags -> CommonSetupFlags)+      -> Args+      -> flags+      -> IO HookedBuildInfo+    readHook get_common_flags args flags = do+      let common = get_common_flags flags+          verbosity = fromFlag (setupVerbosity common)+          mbWorkDir = flagToMaybe $ setupWorkingDir common+          distPref = setupDistPref common+      noExtraFlags args+      dist_dir <- findDistPrefOrDefault distPref+      getHookedBuildInfo verbosity mbWorkDir (dist_dir </> makeRelativePathEx "build")++getHookedBuildInfo+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> SymbolicPath Pkg (Dir Build)+  -> IO HookedBuildInfo+getHookedBuildInfo verbosity mbWorkDir build_dir = do+  maybe_infoFile <- findHookedPackageDesc verbosity mbWorkDir build_dir+  case maybe_infoFile of+    Nothing -> return emptyHookedBuildInfo+    Just infoFile -> do+      info verbosity $ "Reading parameters from " ++ getSymbolicPath infoFile+      readHookedBuildInfo verbosity mbWorkDir infoFile++autoconfSetupHooks :: SetupHooks+autoconfSetupHooks =+  SetupHooks.noSetupHooks+    { SetupHooks.configureHooks =+        SetupHooks.noConfigureHooks+          { SetupHooks.postConfPackageHook = Just post_conf_pkg+          , SetupHooks.preConfComponentHook = Just pre_conf_comp+          }+    }+  where+    post_conf_pkg+      :: SetupHooks.PostConfPackageInputs+      -> IO ()+    post_conf_pkg+      ( SetupHooks.PostConfPackageInputs+          { SetupHooks.localBuildConfig =+            LBC.LocalBuildConfig{LBC.withPrograms = progs}+          , SetupHooks.packageBuildDescr =+            LBC.PackageBuildDescr+              { LBC.configFlags = cfg+              , LBC.flagAssignment = flags+              , LBC.hostPlatform = plat+              }+          }+        ) = runConfigureScript cfg flags progs plat++    pre_conf_comp+      :: SetupHooks.PreConfComponentInputs+      -> IO SetupHooks.PreConfComponentOutputs+    pre_conf_comp+      ( SetupHooks.PreConfComponentInputs+          { SetupHooks.packageBuildDescr =+            LBC.PackageBuildDescr+              { LBC.configFlags = cfg+              , localPkgDescr = pkg_descr+              }+          , SetupHooks.component = component+          }+        ) = do+        let verbosity = fromFlag $ configVerbosity cfg+            mbWorkDir = flagToMaybe $ configWorkingDir cfg+            distPref = configDistPref cfg+        dist_dir <- findDistPrefOrDefault distPref+        -- Read the ".buildinfo" file and use that to update+        -- the components (main library + executables only).+        hbi <- getHookedBuildInfo verbosity mbWorkDir (dist_dir </> makeRelativePathEx "build")+        sanityCheckHookedBuildInfo verbosity pkg_descr hbi+        -- SetupHooks TODO: we are reading getHookedBuildInfo once+        -- for each component. I think this is inherent to the SetupHooks+        -- approach.+        let comp_name = componentName component+        diff <- case SetupHooks.hookedBuildInfoComponentDiff_maybe hbi comp_name of+          Nothing -> return $ SetupHooks.emptyComponentDiff comp_name+          Just do_diff -> do_diff+        return $+          SetupHooks.PreConfComponentOutputs+            { SetupHooks.componentDiff = diff+            }++defaultTestHook+  :: Args+  -> PackageDescription+  -> LocalBuildInfo+  -> UserHooks+  -> TestFlags+  -> IO ()+defaultTestHook args pkg_descr localbuildinfo _ flags =+  test args pkg_descr localbuildinfo flags++defaultBenchHook+  :: Args+  -> PackageDescription+  -> LocalBuildInfo+  -> UserHooks+  -> BenchmarkFlags+  -> IO ()+defaultBenchHook args pkg_descr localbuildinfo _ flags =+  bench args pkg_descr localbuildinfo flags++defaultInstallHook+  :: PackageDescription+  -> LocalBuildInfo+  -> UserHooks+  -> InstallFlags+  -> IO ()+defaultInstallHook =+  defaultInstallHook_setupHooks SetupHooks.noInstallHooks++defaultInstallHook_setupHooks+  :: SetupHooks.InstallHooks+  -> PackageDescription+  -> LocalBuildInfo+  -> UserHooks+  -> InstallFlags+  -> IO ()+defaultInstallHook_setupHooks inst_hooks pkg_descr localbuildinfo _ flags = do+  let copyFlags =+        defaultCopyFlags+          { copyDest = installDest flags+          , copyCommonFlags = installCommonFlags flags+          }+  install_setupHooks inst_hooks pkg_descr localbuildinfo copyFlags+  let registerFlags =+        defaultRegisterFlags+          { regInPlace = installInPlace flags+          , regPackageDB = installPackageDB flags+          , registerCommonFlags = installCommonFlags flags+          }+  when (hasLibs pkg_descr) $+    register pkg_descr localbuildinfo registerFlags++defaultBuildHook+  :: PackageDescription+  -> LocalBuildInfo+  -> UserHooks+  -> BuildFlags+  -> IO ()+defaultBuildHook pkg_descr localbuildinfo hooks flags =+  build pkg_descr localbuildinfo flags (allSuffixHandlers hooks)++defaultReplHook+  :: PackageDescription+  -> LocalBuildInfo+  -> UserHooks+  -> ReplFlags+  -> [String]+  -> IO ()+defaultReplHook pkg_descr localbuildinfo hooks flags args =+  repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args++defaultRegHook+  :: PackageDescription+  -> LocalBuildInfo+  -> UserHooks+  -> RegisterFlags+  -> IO ()+defaultRegHook pkg_descr localbuildinfo _ flags =+  if hasLibs pkg_descr+    then register pkg_descr localbuildinfo flags+    else+      setupMessage+        (fromFlag (setupVerbosity $ registerCommonFlags flags))+        "Package contains no library to register:"+        (packageId pkg_descr)
src/Distribution/Simple/Bench.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Bench -- Copyright   :  Johan Tibell 2011@@ -13,113 +15,166 @@ -- This is the entry point into running the benchmarks in a built -- package. It performs the \"@.\/setup bench@\" action. It runs -- benchmarks designated in the package description.- module Distribution.Simple.Bench-    ( bench-    ) where+  ( bench+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD+import Distribution.Pretty+import Distribution.Simple.Build (addInternalBuildTools) import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler+import Distribution.Simple.Errors import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI-import Distribution.Simple.Setup+import Distribution.Simple.Program.Db+import Distribution.Simple.Program.Find+import Distribution.Simple.Program.Run+import Distribution.Simple.Setup.Benchmark+import Distribution.Simple.Setup.Common import Distribution.Simple.UserHooks import Distribution.Simple.Utils-import Distribution.Pretty+import Distribution.System (Platform (Platform))+import Distribution.Types.Benchmark (Benchmark (benchmarkBuildInfo))+import Distribution.Types.UnqualComponentName+import Distribution.Utils.Path -import System.Directory ( doesFileExist )-import System.FilePath ( (</>), (<.>) )+import System.Directory (doesFileExist)  -- | Perform the \"@.\/setup bench@\" action.-bench :: Args                    -- ^positional command-line arguments-      -> PD.PackageDescription   -- ^information from the .cabal file-      -> LBI.LocalBuildInfo      -- ^information from the configure step-      -> BenchmarkFlags          -- ^flags sent to benchmark-      -> IO ()+bench+  :: Args+  -- ^ positional command-line arguments+  -> PD.PackageDescription+  -- ^ information from the .cabal file+  -> LBI.LocalBuildInfo+  -- ^ information from the configure step+  -> BenchmarkFlags+  -- ^ flags sent to benchmark+  -> IO () bench args pkg_descr lbi flags = do-    let verbosity         = fromFlag $ benchmarkVerbosity flags-        benchmarkNames    = args-        pkgBenchmarks     = PD.benchmarks pkg_descr-        enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi)+  curDir <- LBI.absoluteWorkingDirLBI lbi+  let verbosity = fromFlag $ benchmarkVerbosity flags+      benchmarkNames = args+      pkgBenchmarks = PD.benchmarks pkg_descr+      enabledBenchmarks = LBI.enabledBenchLBIs pkg_descr lbi+      mbWorkDir = flagToMaybe $ benchmarkWorkingDir flags+      i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path -        -- Run the benchmark-        doBench :: PD.Benchmark -> IO ExitCode-        doBench bm =-            case PD.benchmarkInterface bm of-              PD.BenchmarkExeV10 _ _ -> do-                  let cmd = LBI.buildDir lbi </> name </> name <.> exeExtension (LBI.hostPlatform lbi)-                      options = map (benchOption pkg_descr lbi bm) $-                                benchmarkOptions flags-                  -- Check that the benchmark executable exists.-                  exists <- doesFileExist cmd-                  unless exists $ die' verbosity $-                      "Error: Could not find benchmark program \""-                      ++ cmd ++ "\". Did you build the package first?"+      -- Run the benchmark+      doBench :: (PD.Benchmark, LBI.ComponentLocalBuildInfo) -> IO ExitCode+      doBench (bm, clbi) = do+        let lbiForBench =+              lbi+                { -- Include any build-tool-depends on build tools internal to the current package.+                  LBI.withPrograms =+                    addInternalBuildTools+                      curDir+                      pkg_descr+                      lbi+                      (benchmarkBuildInfo bm)+                      (LBI.withPrograms lbi)+                }+        case PD.benchmarkInterface bm of+          PD.BenchmarkExeV10 _ _ -> do+            let cmd = i $ LBI.buildDir lbiForBench </> makeRelativePathEx (name </> name <.> exeExtension (LBI.hostPlatform lbi))+                options =+                  map (benchOption pkg_descr lbiForBench bm) $+                    benchmarkOptions flags+            -- Check that the benchmark executable exists.+            exists <- doesFileExist cmd+            unless exists $+              dieWithException verbosity $+                NoBenchMarkProgram cmd -                  notice verbosity $ startMessage name-                  -- This will redirect the child process-                  -- stdout/stderr to the parent process.-                  exitcode <- rawSystemExitCode verbosity cmd options-                  notice verbosity $ finishMessage name exitcode-                  return exitcode+            -- Compute the appropriate environment for running the benchmark+            let progDb = LBI.withPrograms lbiForBench+                pathVar = progSearchPath progDb+                envOverrides = progOverrideEnv progDb+            newPath <- programSearchPathAsPATHVar pathVar+            shellEnv <- getFullEnvironment ([("PATH", Just newPath)] ++ envOverrides) -              _ -> do-                  notice verbosity $ "No support for running "-                      ++ "benchmark " ++ name ++ " of type: "-                      ++ prettyShow (PD.benchmarkType bm)-                  exitFailure-          where name = unUnqualComponentName $ PD.benchmarkName bm+            -- Add (DY)LD_LIBRARY_PATH if needed+            shellEnv' <-+              if LBI.withDynExe lbiForBench+                then do+                  let (Platform _ os) = LBI.hostPlatform lbiForBench+                  paths <- LBI.depLibraryPaths True False lbiForBench clbi+                  return (addLibraryPath os paths shellEnv)+                else return shellEnv -    unless (PD.hasBenchmarks pkg_descr) $ do-        notice verbosity "Package has no benchmarks."-        exitSuccess+            notice verbosity $ startMessage name+            -- This will redirect the child process+            -- stdout/stderr to the parent process.+            exitcode <- rawSystemExitCode verbosity mbWorkDir cmd options (Just shellEnv')+            notice verbosity $ finishMessage name exitcode+            return exitcode+          _ -> do+            notice verbosity $+              "No support for running "+                ++ "benchmark "+                ++ name+                ++ " of type: "+                ++ prettyShow (PD.benchmarkType bm)+            exitFailure+        where+          name = unUnqualComponentName $ PD.benchmarkName bm -    when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $-        die' verbosity $ "No benchmarks enabled. Did you remember to configure with "-              ++ "\'--enable-benchmarks\'?"+  unless (PD.hasBenchmarks pkg_descr) $ do+    notice verbosity "Package has no benchmarks."+    exitSuccess -    bmsToRun <- case benchmarkNames of-            [] -> return enabledBenchmarks-            names -> for names $ \bmName ->-                let benchmarkMap = zip enabledNames enabledBenchmarks-                    enabledNames = map PD.benchmarkName enabledBenchmarks-                    allNames = map PD.benchmarkName pkgBenchmarks-                in case lookup (mkUnqualComponentName bmName) benchmarkMap of-                    Just t -> return t-                    _ | mkUnqualComponentName bmName `elem` allNames ->-                          die' verbosity $ "Package configured with benchmark "-                                ++ bmName ++ " disabled."-                      | otherwise -> die' verbosity $ "no such benchmark: " ++ bmName+  when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $+    dieWithException verbosity EnableBenchMark -    let totalBenchmarks = length bmsToRun-    notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."-    exitcodes <- traverse doBench bmsToRun-    let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes)-    unless allOk exitFailure+  bmsToRun <- case benchmarkNames of+    [] -> return enabledBenchmarks+    names -> for names $ \bmName ->+      let benchmarkMap = zip enabledNames enabledBenchmarks+          enabledNames = map (PD.benchmarkName . fst) enabledBenchmarks+          allNames = map PD.benchmarkName pkgBenchmarks+       in case lookup (mkUnqualComponentName bmName) benchmarkMap of+            Just t -> return t+            _+              | mkUnqualComponentName bmName `elem` allNames ->+                  dieWithException verbosity $ BenchMarkNameDisabled bmName+              | otherwise -> dieWithException verbosity $ NoBenchMark bmName++  let totalBenchmarks = length bmsToRun+  notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."+  exitcodes <- traverse doBench bmsToRun++  let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes)+  unless allOk exitFailure   where     startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n"-    finishMessage name exitcode = "Benchmark " ++ name ++ ": "-                               ++ (case exitcode of-                                        ExitSuccess -> "FINISH"-                                        ExitFailure _ -> "ERROR")-+    finishMessage name exitcode =+      "Benchmark "+        ++ name+        ++ ": "+        ++ ( case exitcode of+              ExitSuccess -> "FINISH"+              ExitFailure _ -> "ERROR"+           )  -- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't -- necessarily a path.-benchOption :: PD.PackageDescription-            -> LBI.LocalBuildInfo-            -> PD.Benchmark-            -> PathTemplate-            -> String+benchOption+  :: PD.PackageDescription+  -> LBI.LocalBuildInfo+  -> PD.Benchmark+  -> PathTemplate+  -> String benchOption pkg_descr lbi bm template =-    fromPathTemplate $ substPathTemplate env template+  fromPathTemplate $ substPathTemplate env template   where-    env = initialPathTemplateEnv-          (PD.package pkg_descr) (LBI.localUnitId lbi)-          (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++-          [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)]+    env =+      initialPathTemplateEnv+        (PD.package pkg_descr)+        (LBI.localUnitId lbi)+        (compilerInfo $ LBI.compiler lbi)+        (LBI.hostPlatform lbi)+        ++ [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)]
src/Distribution/Simple/Build.hs view
@@ -1,734 +1,1240 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Build--- Copyright   :  Isaac Jones 2003-2005,---                Ross Paterson 2006,---                Duncan Coutts 2007-2008, 2012--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This is the entry point to actually building the modules in a package. It--- doesn't actually do much itself, most of the work is delegated to--- compiler-specific actions. It does do some non-compiler specific bits like--- running pre-processors.-----module Distribution.Simple.Build (-    build, showBuildInfo, repl,-    startInterpreter,--    initialBuildSteps,-    createInternalPackageDB,-    componentInitialBuildSteps,-    writeAutogenFiles,-  ) where--import Prelude ()-import Distribution.Compat.Prelude-import Distribution.Utils.Generic--import Distribution.Types.ComponentLocalBuildInfo-import Distribution.Types.ComponentRequestedSpec-import Distribution.Types.Dependency-import Distribution.Types.ExecutableScope-import Distribution.Types.ForeignLib-import Distribution.Types.LibraryVisibility-import Distribution.Types.LocalBuildInfo-import Distribution.Types.MungedPackageId-import Distribution.Types.MungedPackageName-import Distribution.Types.ModuleRenaming-import Distribution.Types.TargetInfo-import Distribution.Utils.Path--import Distribution.Package-import Distribution.Backpack-import Distribution.Backpack.DescribeUnitId-import qualified Distribution.Simple.GHC   as GHC-import qualified Distribution.Simple.GHCJS as GHCJS-import qualified Distribution.Simple.UHC   as UHC-import qualified Distribution.Simple.HaskellSuite as HaskellSuite-import qualified Distribution.Simple.PackageIndex as Index--import Distribution.Simple.Build.Macros      (generateCabalMacrosHeader)-import Distribution.Simple.Build.PathsModule (generatePathsModule)-import qualified Distribution.Simple.Program.HcPkg as HcPkg--import Distribution.Simple.Compiler-import Distribution.PackageDescription-import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.InstalledPackageInfo (InstalledPackageInfo)-import qualified Distribution.ModuleName as ModuleName--import Distribution.Simple.Setup-import Distribution.Simple.BuildTarget-import Distribution.Simple.BuildToolDepends-import Distribution.Simple.PreProcess-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Program.Types-import Distribution.Simple.Program.Db-import Distribution.Simple.ShowBuildInfo-import Distribution.Simple.BuildPaths-import Distribution.Simple.Configure-import Distribution.Simple.Register-import Distribution.Simple.Test.LibV09-import Distribution.Simple.Utils-import Distribution.Simple.Utils.Json--import Distribution.System-import Distribution.Pretty-import Distribution.Verbosity-import Distribution.Version (thisVersion)--import Distribution.Compat.Graph (IsNode(..))--import Control.Monad-import qualified Data.Set as Set-import System.FilePath ( (</>), (<.>), takeDirectory )-import System.Directory ( getCurrentDirectory )---- -------------------------------------------------------------------------------- |Build the libraries and executables in this package.--build    :: PackageDescription  -- ^ Mostly information from the .cabal file-         -> LocalBuildInfo      -- ^ Configuration information-         -> BuildFlags          -- ^ Flags that the user passed to build-         -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling-         -> IO ()-build pkg_descr lbi flags suffixes = do-  targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags)-  let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)-  info verbosity $ "Component build order: "-                ++ intercalate ", "-                    (map (showComponentName . componentLocalName . targetCLBI)-                        componentsToBuild)--  when (null targets) $-    -- Only bother with this message if we're building the whole package-    setupMessage verbosity "Building" (packageId pkg_descr)--  internalPackageDB <- createInternalPackageDB verbosity lbi distPref--  (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do-    let comp = targetComponent target-        clbi = targetCLBI target-    componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity-    let bi     = componentBuildInfo comp-        progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)-        lbi'   = lbi {-                   withPrograms  = progs',-                   withPackageDB = withPackageDB lbi ++ [internalPackageDB],-                   installedPkgs = index-                 }-    mb_ipi <- buildComponent verbosity (buildNumJobs flags) pkg_descr-                   lbi' suffixes comp clbi distPref-    return (maybe index (Index.insert `flip` index) mb_ipi)-  return ()- where-  distPref  = fromFlag (buildDistPref flags)-  verbosity = fromFlag (buildVerbosity flags)---showBuildInfo :: PackageDescription  -- ^ Mostly information from the .cabal file-  -> LocalBuildInfo      -- ^ Configuration information-  -> BuildFlags          -- ^ Flags that the user passed to build-  -> IO String-showBuildInfo pkg_descr lbi flags = do-  let verbosity = fromFlag (buildVerbosity flags)-  targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags)-  let targetsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)-      doc = mkBuildInfo pkg_descr lbi flags targetsToBuild-  return $ renderJson doc ""---repl     :: PackageDescription  -- ^ Mostly information from the .cabal file-         -> LocalBuildInfo      -- ^ Configuration information-         -> ReplFlags           -- ^ Flags that the user passed to build-         -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling-         -> [String]-         -> IO ()-repl pkg_descr lbi flags suffixes args = do-  let distPref  = fromFlag (replDistPref flags)-      verbosity = fromFlag (replVerbosity flags)--  target <- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of-    -- This seems DEEPLY questionable.-    []       -> case allTargetsInBuildOrder' pkg_descr lbi of-      (target:_) -> return target-      []         -> die' verbosity $ "Failed to determine target."-    [target] -> return target-    _        -> die' verbosity $ "The 'repl' command does not support multiple targets at once."-  let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target]-  debug verbosity $ "Component build order: "-                 ++ intercalate ", "-                      (map (showComponentName . componentLocalName . targetCLBI)-                           componentsToBuild)--  internalPackageDB <- createInternalPackageDB verbosity lbi distPref--  let lbiForComponent comp lbi' =-        lbi' {-          withPackageDB = withPackageDB lbi ++ [internalPackageDB],-          withPrograms  = addInternalBuildTools pkg_descr lbi'-                            (componentBuildInfo comp) (withPrograms lbi')-        }--  -- build any dependent components-  sequence_-    [ do let clbi = targetCLBI subtarget-             comp = targetComponent subtarget-             lbi' = lbiForComponent comp lbi-         componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity-         buildComponent verbosity NoFlag-                        pkg_descr lbi' suffixes comp clbi distPref-    | subtarget <- safeInit componentsToBuild ]--  -- REPL for target components-  let clbi = targetCLBI target-      comp = targetComponent target-      lbi' = lbiForComponent comp lbi-      replFlags = replReplOptions flags-  componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity-  replComponent replFlags verbosity pkg_descr lbi' suffixes comp clbi distPref----- | Start an interpreter without loading any package files.-startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform-                 -> PackageDBStack -> IO ()-startInterpreter verbosity programDb comp platform packageDBs =-  case compilerFlavor comp of-    GHC   -> GHC.startInterpreter   verbosity programDb comp platform packageDBs-    GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs-    _     -> die' verbosity "A REPL is not supported with this compiler."--buildComponent :: Verbosity-               -> Flag (Maybe Int)-               -> PackageDescription-               -> LocalBuildInfo-               -> [PPSuffixHandler]-               -> Component-               -> ComponentLocalBuildInfo-               -> FilePath-               -> IO (Maybe InstalledPackageInfo)-buildComponent verbosity numJobs pkg_descr lbi suffixes-               comp@(CLib lib) clbi distPref = do-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    setupMessage' verbosity "Building" (packageId pkg_descr)-      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)-    let libbi = libBuildInfo lib-        lib' = lib { libBuildInfo = flip addExtraAsmSources extras-                                  $ flip addExtraCmmSources extras-                                  $ flip addExtraCxxSources extras-                                  $ flip addExtraCSources   extras-                                  $ libbi-                   }--    buildLib verbosity 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)))-      then do-        -- Register the library in-place, so exes can depend-        -- on internally defined libraries.-        pwd <- getCurrentDirectory-        let -- The in place registration uses the "-inplace" suffix, not an ABI hash-            installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr-                                    -- NB: Use a fake ABI hash to avoid-                                    -- needing to recompute it every build.-                                    (mkAbiHash "inplace") lib' lbi clbi--        debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo)-        registerPackage verbosity (compiler lbi) (withPrograms lbi)-                        (withPackageDB lbi) installedPkgInfo-                        HcPkg.defaultRegisterOptions {-                          HcPkg.registerMultiInstance = True-                        }-        return (Just installedPkgInfo)-      else return Nothing--buildComponent verbosity numJobs pkg_descr lbi suffixes-               comp@(CFLib flib) clbi _distPref = do-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    setupMessage' verbosity "Building" (packageId pkg_descr)-      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)-    buildFLib verbosity numJobs pkg_descr lbi flib clbi-    return Nothing--buildComponent verbosity numJobs pkg_descr lbi suffixes-               comp@(CExe exe) clbi _ = do-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    setupMessage' verbosity "Building" (packageId pkg_descr)-      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)-    let ebi = buildInfo exe-        exe' = exe { buildInfo = addExtraCSources ebi extras }-    buildExe verbosity numJobs pkg_descr lbi exe' clbi-    return Nothing---buildComponent verbosity numJobs pkg_descr lbi suffixes-               comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })-               clbi _distPref = do-    let exe = testSuiteExeV10AsExe test-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    setupMessage' verbosity "Building" (packageId pkg_descr)-      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)-    let ebi = buildInfo exe-        exe' = exe { buildInfo = addExtraCSources ebi extras }-    buildExe verbosity numJobs pkg_descr lbi exe' clbi-    return Nothing---buildComponent verbosity numJobs pkg_descr lbi0 suffixes-               comp@(CTest-                 test@TestSuite { testInterface = TestSuiteLibV09{} })-               clbi -- This ComponentLocalBuildInfo corresponds to a detailed-                    -- test suite and not a real component. It should not-                    -- be used, except to construct the CLBIs for the-                    -- library and stub executable that will actually be-                    -- built.-               distPref = do-    pwd <- getCurrentDirectory-    let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) =-          testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    setupMessage' verbosity "Building" (packageId pkg_descr)-      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)-    buildLib verbosity numJobs pkg lbi lib libClbi-    -- NB: need to enable multiple instances here, because on 7.10+-    -- the package name is the same as the library, and we still-    -- want the registration to go through.-    registerPackage verbosity (compiler lbi) (withPrograms lbi)-                    (withPackageDB lbi) ipi-                    HcPkg.defaultRegisterOptions {-                      HcPkg.registerMultiInstance = True-                    }-    let ebi = buildInfo exe-        -- NB: The stub executable is linked against the test-library-        --     which already contains all `other-modules`, so we need-        --     to remove those from the stub-exe's build-info-        exe' = exe { buildInfo = (addExtraCSources ebi extras) { otherModules = [] } }-    buildExe verbosity numJobs pkg_descr lbi exe' exeClbi-    return Nothing -- Can't depend on test suite---buildComponent verbosity _ _ _ _-               (CTest TestSuite { testInterface = TestSuiteUnsupported tt })-               _ _ =-    die' verbosity $ "No support for building test suite type " ++ prettyShow tt---buildComponent verbosity numJobs pkg_descr lbi suffixes-               comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })-               clbi _distPref = do-    let exe = benchmarkExeV10asExe bm-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    setupMessage' verbosity "Building" (packageId pkg_descr)-      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)-    let ebi = buildInfo exe-        exe' = exe { buildInfo = addExtraCSources ebi extras }-    buildExe verbosity numJobs pkg_descr lbi exe' clbi-    return Nothing---buildComponent verbosity _ _ _ _-               (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })-               _ _ =-    die' verbosity $ "No support for building benchmark type " ++ prettyShow tt----- | Add extra C sources generated by preprocessing to build--- information.-addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo-addExtraCSources bi extras = bi { cSources = new }-  where new = Set.toList $ old `Set.union` exs-        old = Set.fromList $ cSources bi-        exs = Set.fromList extras----- | Add extra C++ sources generated by preprocessing to build--- information.-addExtraCxxSources :: BuildInfo -> [FilePath] -> BuildInfo-addExtraCxxSources bi extras = bi { cxxSources = new }-  where new = Set.toList $ old `Set.union` exs-        old = Set.fromList $ cxxSources bi-        exs = Set.fromList extras----- | Add extra C-- sources generated by preprocessing to build--- information.-addExtraCmmSources :: BuildInfo -> [FilePath] -> BuildInfo-addExtraCmmSources bi extras = bi { cmmSources = new }-  where new = Set.toList $ old `Set.union` exs-        old = Set.fromList $ cmmSources bi-        exs = Set.fromList extras----- | Add extra ASM sources generated by preprocessing to build--- information.-addExtraAsmSources :: BuildInfo -> [FilePath] -> BuildInfo-addExtraAsmSources bi extras = bi { asmSources = new }-  where new = Set.toList $ old `Set.union` exs-        old = Set.fromList $ asmSources bi-        exs = Set.fromList extras---replComponent :: [String]-              -> Verbosity-              -> PackageDescription-              -> LocalBuildInfo-              -> [PPSuffixHandler]-              -> Component-              -> ComponentLocalBuildInfo-              -> FilePath-              -> IO ()-replComponent replFlags verbosity pkg_descr lbi suffixes-               comp@(CLib lib) clbi _ = do-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    let libbi = libBuildInfo lib-        lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } }-    replLib replFlags verbosity pkg_descr lbi lib' clbi--replComponent replFlags verbosity pkg_descr lbi suffixes-               comp@(CFLib flib) clbi _ = do-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    replFLib replFlags verbosity pkg_descr lbi flib clbi--replComponent replFlags verbosity pkg_descr lbi suffixes-               comp@(CExe exe) clbi _ = do-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    let ebi = buildInfo exe-        exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }-    replExe replFlags verbosity pkg_descr lbi exe' clbi---replComponent replFlags verbosity pkg_descr lbi suffixes-               comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })-               clbi _distPref = do-    let exe = testSuiteExeV10AsExe test-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    let ebi = buildInfo exe-        exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }-    replExe replFlags verbosity pkg_descr lbi exe' clbi---replComponent replFlags verbosity pkg_descr lbi0 suffixes-               comp@(CTest-                 test@TestSuite { testInterface = TestSuiteLibV09{} })-               clbi distPref = do-    pwd <- getCurrentDirectory-    let (pkg, lib, libClbi, lbi, _, _, _) =-          testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    let libbi = libBuildInfo lib-        lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } }-    replLib replFlags verbosity pkg lbi lib' libClbi---replComponent _ verbosity _ _ _-              (CTest TestSuite { testInterface = TestSuiteUnsupported tt })-              _ _ =-    die' verbosity $ "No support for building test suite type " ++ prettyShow tt---replComponent replFlags verbosity pkg_descr lbi suffixes-               comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })-               clbi _distPref = do-    let exe = benchmarkExeV10asExe bm-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    let ebi = buildInfo exe-        exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }-    replExe replFlags verbosity pkg_descr lbi exe' clbi---replComponent _ verbosity _ _ _-              (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })-              _ _ =-    die' verbosity $ "No support for building benchmark type " ++ prettyShow tt--------------------------------------------------------- Shared code for buildComponent and replComponent------- | Translate a exe-style 'TestSuite' component into an exe for building-testSuiteExeV10AsExe :: TestSuite -> Executable-testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } =-    Executable {-      exeName    = testName test,-      modulePath = mainFile,-      exeScope   = ExecutablePublic,-      buildInfo  = testBuildInfo test-    }-testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind"---- | Translate a exe-style 'Benchmark' component into an exe for building-benchmarkExeV10asExe :: Benchmark -> Executable-benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ mainFile } =-    Executable {-      exeName    = benchmarkName bm,-      modulePath = mainFile,-      exeScope   = ExecutablePublic,-      buildInfo  = benchmarkBuildInfo bm-    }-benchmarkExeV10asExe Benchmark{} = error "benchmarkExeV10asExe: wrong kind"---- | Translate a lib-style 'TestSuite' component into a lib + exe for building-testSuiteLibV09AsLibAndExe :: PackageDescription-                           -> TestSuite-                           -> ComponentLocalBuildInfo-                           -> LocalBuildInfo-                           -> FilePath-                           -> FilePath-                           -> (PackageDescription,-                               Library, ComponentLocalBuildInfo,-                               LocalBuildInfo,-                               IPI.InstalledPackageInfo,-                               Executable, ComponentLocalBuildInfo)-testSuiteLibV09AsLibAndExe pkg_descr-                     test@TestSuite { testInterface = TestSuiteLibV09 _ m }-                     clbi lbi distPref pwd =-    (pkg, lib, libClbi, lbi, ipi, exe, exeClbi)-  where-    bi  = testBuildInfo test-    lib = Library {-            libName = LMainLibName,-            exposedModules = [ m ],-            reexportedModules = [],-            signatures = [],-            libExposed     = True,-            libVisibility  = LibraryVisibilityPrivate,-            libBuildInfo   = bi-          }-    -- This is, like, the one place where we use a CTestName for a library.-    -- Should NOT use library name, since that could conflict!-    PackageIdentifier pkg_name pkg_ver = package pkg_descr-    -- Note: we do make internal library from the test!-    compat_name = MungedPackageName pkg_name (LSubLibName (testName test))-    compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi)-    libClbi = LibComponentLocalBuildInfo-                { componentPackageDeps = componentPackageDeps clbi-                , componentInternalDeps = componentInternalDeps clbi-                , componentIsIndefinite_ = False-                , componentExeDeps = componentExeDeps clbi-                , componentLocalName = CLibName $ LSubLibName $ testName test-                , componentIsPublic = False-                , componentIncludes = componentIncludes clbi-                , componentUnitId = componentUnitId clbi-                , componentComponentId = componentComponentId clbi-                , componentInstantiatedWith = []-                , componentCompatPackageName = compat_name-                , componentCompatPackageKey = compat_key-                , componentExposedModules = [IPI.ExposedModule m Nothing]-                }-    pkgName' = mkPackageName $ prettyShow compat_name-    pkg = pkg_descr {-            package      = (package pkg_descr) { pkgName = pkgName' }-          , executables  = []-          , testSuites   = []-          , subLibraries = [lib]-          }-    ipi    = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi-    testDir = buildDir lbi </> stubName test-          </> stubName test ++ "-tmp"-    testLibDep = Dependency-        pkgName'-        (thisVersion $ pkgVersion $ package pkg_descr)-        mainLibSet-    exe = Executable {-            exeName    = mkUnqualComponentName $ stubName test,-            modulePath = stubFilePath test,-            exeScope   = ExecutablePublic,-            buildInfo  = (testBuildInfo test) {-                           hsSourceDirs       = [ unsafeMakeSymbolicPath testDir ],-                           targetBuildDepends = testLibDep-                             : (targetBuildDepends $ testBuildInfo test)-                         }-          }-    -- | The stub executable needs a new 'ComponentLocalBuildInfo'-    -- that exposes the relevant test suite library.-    deps = (IPI.installedUnitId ipi, mungedId ipi)-         : (filter (\(_, x) -> let name = prettyShow $ mungedName x-                               in name == "Cabal" || name == "base")-                   (componentPackageDeps clbi))-    exeClbi = ExeComponentLocalBuildInfo {-                -- TODO: this is a hack, but as long as this is unique-                -- (doesn't clobber something) we won't run into trouble-                componentUnitId = mkUnitId (stubName test),-                componentComponentId = mkComponentId (stubName test),-                componentInternalDeps = [componentUnitId clbi],-                componentExeDeps = [],-                componentLocalName = CExeName $ mkUnqualComponentName $ stubName test,-                componentPackageDeps = deps,-                -- Assert DefUnitId invariant!-                -- Executable can't be indefinite, so dependencies must-                -- be definite packages.-                componentIncludes = zip (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps)-                                        (repeat defaultRenaming)-              }-testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"----- | Initialize a new package db file for libraries defined--- internally to the package.-createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath-                        -> IO PackageDB-createInternalPackageDB verbosity lbi distPref = do-    existsAlready <- doesPackageDBExist dbPath-    when existsAlready $ deletePackageDB dbPath-    createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath-    return (SpecificPackageDB dbPath)-  where-    dbPath = internalPackageDBPath lbi distPref--addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo-                      -> ProgramDb -> ProgramDb-addInternalBuildTools pkg lbi bi progs =-    foldr updateProgram progs internalBuildTools-  where-    internalBuildTools =-      [ simpleConfiguredProgram toolName' (FoundOnSystem toolLocation)-      | toolName <- getAllInternalToolDependencies pkg bi-      , let toolName' = unUnqualComponentName toolName-      , let toolLocation = buildDir lbi </> toolName' </> toolName' <.> exeExtension (hostPlatform lbi) ]----- TODO: build separate libs in separate dirs so that we can build--- multiple libs, e.g. for 'LibTest' library-style test suites-buildLib :: Verbosity -> Flag (Maybe Int)-                      -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity numJobs pkg_descr lbi lib clbi =-  case compilerFlavor (compiler lbi) of-    GHC   -> GHC.buildLib   verbosity numJobs pkg_descr lbi lib clbi-    GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi-    UHC   -> UHC.buildLib   verbosity         pkg_descr lbi lib clbi-    HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi-    _    -> die' verbosity "Building is not supported with this compiler."---- | Build a foreign library------ NOTE: We assume that we already checked that we can actually build the--- foreign library in configure.-buildFLib :: Verbosity -> Flag (Maybe Int)-                       -> PackageDescription -> LocalBuildInfo-                       -> ForeignLib         -> ComponentLocalBuildInfo -> IO ()-buildFLib verbosity numJobs pkg_descr lbi flib clbi =-    case compilerFlavor (compiler lbi) of-      GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi-      _   -> die' verbosity "Building is not supported with this compiler."--buildExe :: Verbosity -> Flag (Maybe Int)-                      -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity numJobs pkg_descr lbi exe clbi =-  case compilerFlavor (compiler lbi) of-    GHC   -> GHC.buildExe   verbosity numJobs pkg_descr lbi exe clbi-    GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi-    UHC   -> UHC.buildExe   verbosity         pkg_descr lbi exe clbi-    _     -> die' verbosity "Building is not supported with this compiler."--replLib :: [String]        -> Verbosity -> PackageDescription-        -> LocalBuildInfo  -> Library   -> ComponentLocalBuildInfo-        -> IO ()-replLib replFlags verbosity pkg_descr lbi lib clbi =-  case compilerFlavor (compiler lbi) of-    -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass-    -- NoFlag as the numJobs parameter.-    GHC   -> GHC.replLib   replFlags verbosity NoFlag pkg_descr lbi lib clbi-    GHCJS -> GHCJS.replLib replFlags verbosity NoFlag pkg_descr lbi lib clbi-    _     -> die' verbosity "A REPL is not supported for this compiler."--replExe :: [String]        -> Verbosity  -> PackageDescription-        -> LocalBuildInfo  -> Executable -> ComponentLocalBuildInfo-        -> IO ()-replExe replFlags verbosity pkg_descr lbi exe clbi =-  case compilerFlavor (compiler lbi) of-    GHC   -> GHC.replExe   replFlags verbosity NoFlag pkg_descr lbi exe clbi-    GHCJS -> GHCJS.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi-    _     -> die' verbosity "A REPL is not supported for this compiler."--replFLib :: [String]        -> Verbosity  -> PackageDescription-         -> LocalBuildInfo  -> ForeignLib -> ComponentLocalBuildInfo-         -> IO ()-replFLib replFlags verbosity pkg_descr lbi exe clbi =-  case compilerFlavor (compiler lbi) of-    GHC -> GHC.replFLib replFlags verbosity NoFlag pkg_descr lbi exe clbi-    _   -> die' verbosity "A REPL is not supported for this compiler."---- | Runs 'componentInitialBuildSteps' on every configured component.-initialBuildSteps :: FilePath -- ^"dist" prefix-                  -> PackageDescription  -- ^mostly information from the .cabal file-                  -> LocalBuildInfo -- ^Configuration information-                  -> Verbosity -- ^The verbosity to use-                  -> IO ()-initialBuildSteps distPref pkg_descr lbi verbosity =-    withAllComponentsInBuildOrder pkg_descr lbi $ \_comp clbi ->-        componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity---- | Creates the autogenerated files for a particular configured component.-componentInitialBuildSteps :: FilePath -- ^"dist" prefix-                  -> PackageDescription  -- ^mostly information from the .cabal file-                  -> LocalBuildInfo -- ^Configuration information-                  -> ComponentLocalBuildInfo-                  -> Verbosity -- ^The verbosity to use-                  -> IO ()-componentInitialBuildSteps _distPref pkg_descr lbi clbi verbosity = do-  createDirectoryIfMissingVerbose verbosity True (componentBuildDir lbi clbi)--  writeAutogenFiles verbosity pkg_descr lbi clbi---- | Generate and write out the Paths_<pkg>.hs and cabal_macros.h files----writeAutogenFiles :: Verbosity-                  -> PackageDescription-                  -> LocalBuildInfo-                  -> ComponentLocalBuildInfo-                  -> IO ()-writeAutogenFiles verbosity pkg lbi clbi = do-  createDirectoryIfMissingVerbose verbosity True (autogenComponentModulesDir lbi clbi)--  let pathsModulePath = autogenComponentModulesDir lbi clbi-                 </> ModuleName.toFilePath (autogenPathsModuleName pkg) <.> "hs"-      pathsModuleDir = takeDirectory pathsModulePath-  -- Ensure that the directory exists!-  createDirectoryIfMissingVerbose verbosity True pathsModuleDir-  rewriteFileEx verbosity pathsModulePath (generatePathsModule pkg lbi clbi)--  --TODO: document what we're doing here, and move it to its own function-  case clbi of-    LibComponentLocalBuildInfo { componentInstantiatedWith = insts } ->-        -- Write out empty hsig files for all requirements, so that GHC-        -- has a source file to look at it when it needs to typecheck-        -- a signature.  It's harmless to write these out even when-        -- there is a real hsig file written by the user, since-        -- include path ordering ensures that the real hsig file-        -- will always be picked up before the autogenerated one.-        for_ (map fst insts) $ \mod_name -> do-            let sigPath = autogenComponentModulesDir lbi clbi-                      </> ModuleName.toFilePath mod_name <.> "hsig"-            createDirectoryIfMissingVerbose verbosity True (takeDirectory sigPath)-            rewriteFileEx verbosity sigPath $-                "{-# OPTIONS_GHC -w #-}\n" ++-                "{-# LANGUAGE NoImplicitPrelude #-}\n" ++-                "signature " ++ prettyShow mod_name ++ " where"-    _ -> return ()--  let cppHeaderPath = autogenComponentModulesDir lbi clbi </> cppHeaderName-  rewriteFileEx verbosity cppHeaderPath (generateCabalMacrosHeader pkg lbi clbi)+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Build+-- Copyright   :  Isaac Jones 2003-2005,+--                Ross Paterson 2006,+--                Duncan Coutts 2007-2008, 2012+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This is the entry point to actually building the modules in a package. It+-- doesn't actually do much itself, most of the work is delegated to+-- compiler-specific actions. It does do some non-compiler specific bits like+-- running pre-processors.+module Distribution.Simple.Build+  ( -- * Build+    build+  , build_setupHooks++    -- * Repl+  , repl+  , repl_setupHooks+  , startInterpreter++    -- * Build preparation+  , preBuildComponent+  , AutogenFile (..)+  , AutogenFileContents+  , writeBuiltinAutogenFiles+  , writeAutogenFiles++    -- ** Legacy functions+  , componentInitialBuildSteps+  , initialBuildSteps++    -- * Internal package database creation+  , createInternalPackageDB++    -- * Handling of internal build tools+  , addInternalBuildTools+  ) where++import Distribution.Compat.Prelude+import Distribution.Utils.Generic+import Prelude ()++import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.Dependency+import Distribution.Types.ExecutableScope+import Distribution.Types.ForeignLib+import Distribution.Types.LibraryVisibility+import Distribution.Types.LocalBuildInfo+import Distribution.Types.ModuleRenaming+import Distribution.Types.MungedPackageId+import Distribution.Types.MungedPackageName+import Distribution.Types.ParStrat+import Distribution.Types.TargetInfo+import Distribution.Utils.Path++import Distribution.Backpack+import Distribution.Backpack.DescribeUnitId+import Distribution.Package+import qualified Distribution.Simple.GHC as GHC+import qualified Distribution.Simple.GHCJS as GHCJS+import qualified Distribution.Simple.PackageIndex as Index+import qualified Distribution.Simple.UHC as UHC++import Distribution.Simple.Build.Macros (generateCabalMacrosHeader)+import Distribution.Simple.Build.PackageInfoModule (generatePackageInfoModule)+import Distribution.Simple.Build.PathsModule (generatePathsModule, pkgPathEnvVar)+import qualified Distribution.Simple.Program.HcPkg as HcPkg++import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import qualified Distribution.InstalledPackageInfo as IPI+import Distribution.ModuleName (ModuleName)+import qualified Distribution.ModuleName as ModuleName+import Distribution.PackageDescription+import Distribution.Simple.Compiler++import Distribution.Simple.BuildPaths+import Distribution.Simple.BuildTarget+import Distribution.Simple.BuildToolDepends+import Distribution.Simple.Configure+import Distribution.Simple.Flag+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PreProcess+import Distribution.Simple.Program+import Distribution.Simple.Program.Db+import qualified Distribution.Simple.Program.GHC as GHC+import Distribution.Simple.Program.Types+import Distribution.Simple.Register+import Distribution.Simple.Setup.Build+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Config+import Distribution.Simple.Setup.Repl+import Distribution.Simple.SetupHooks.Internal+  ( BuildHooks (..)+  , BuildingWhat (..)+  , noBuildHooks+  )+import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks+import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks+import Distribution.Simple.ShowBuildInfo+import Distribution.Simple.Test.LibV09+import Distribution.Simple.Utils+import Distribution.Utils.Json+import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText)++import Distribution.Pretty+import Distribution.System+import Distribution.Verbosity+import Distribution.Version (thisVersion)++import Distribution.Compat.Graph (IsNode (..))++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)++-- -----------------------------------------------------------------------------++-- | Build the libraries and executables in this package.+build+  :: PackageDescription+  -- ^ Mostly information from the .cabal file+  -> LocalBuildInfo+  -- ^ Configuration information+  -> BuildFlags+  -- ^ Flags that the user passed to build+  -> [PPSuffixHandler]+  -- ^ preprocessors to run before compiling+  -> IO ()+build = build_setupHooks noBuildHooks++build_setupHooks+  :: BuildHooks+  -> PackageDescription+  -- ^ Mostly information from the .cabal file+  -> LocalBuildInfo+  -- ^ Configuration information+  -> BuildFlags+  -- ^ Flags that the user passed to build+  -> [PPSuffixHandler]+  -- ^ preprocessors to run before compiling+  -> IO ()+build_setupHooks+  (BuildHooks{preBuildComponentRules = mbPbcRules, postBuildComponentHook = mbPostBuild})+  pkg_descr+  lbi+  flags+  suffixHandlers = do+    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: "+        ++ intercalate+          ", "+          ( map+              (showComponentName . componentLocalName . targetCLBI)+              componentsToBuild+          )++    when (null targets) $+      -- Only bother with this message if we're building the whole package+      setupMessage verbosity "Building" (packageId pkg_descr)++    internalPackageDB <- createInternalPackageDB verbosity lbi distPref++    -- Before the actual building, dump out build-information.+    -- This way, if the actual compilation failed, the options have still been+    -- dumped.+    dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags lbi)) pkg_descr lbi flags++    curDir <- absoluteWorkingDirLBI lbi++    -- Now do the actual building+    (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do+      let comp = targetComponent target+          clbi = targetCLBI target+          bi = componentBuildInfo comp+          -- Include any build-tool-depends on build tools internal to the current package.+          progs' = addInternalBuildTools curDir pkg_descr lbi bi (withPrograms lbi)+          lbi' =+            lbi+              { withPrograms = progs'+              , withPackageDB = withPackageDB lbi ++ [internalPackageDB]+              , installedPkgs = index+              }+          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+      let numJobs = buildNumJobs flags+      par_strat <-+        toFlag <$> case buildUseSemaphore flags of+          Flag sem_name -> case numJobs of+            Flag{} -> do+              warn verbosity $ "Ignoring -j due to --semaphore"+              return $ UseSem sem_name+            NoFlag -> return $ UseSem sem_name+          NoFlag -> return $ case numJobs of+            Flag n -> NumJobs n+            NoFlag -> Serial+      mb_ipi <-+        buildComponent+          flags+          par_strat+          pkg_descr+          lbi'+          suffixHandlers+          comp+          clbi+          distPref+      let postBuildInputs =+            SetupHooks.PostBuildComponentInputs+              { SetupHooks.buildFlags = flags+              , SetupHooks.localBuildInfo = lbi'+              , SetupHooks.targetInfo = target+              }+      for_ mbPostBuild ($ postBuildInputs)+      return (maybe index (Index.insert `flip` index) mb_ipi)++    return ()+    where+      distPref = fromFlag (buildDistPref flags)+      verbosity = fromFlag (buildVerbosity flags)++-- | 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)))) $+    dieWithException verbosity CheckSemaphoreSupport++-- | Write available build information for 'LocalBuildInfo' to disk.+--+-- Dumps detailed build information 'build-info.json' to the given directory.+-- Build information contains basics such as compiler details, but also+-- lists what modules a component contains and how to compile the component, assuming+-- lib:Cabal made sure that dependencies are up-to-date.+dumpBuildInfo+  :: Verbosity+  -> SymbolicPath Pkg (Dir Dist)+  -- ^ To which directory should the build-info be dumped?+  -> Flag DumpBuildInfo+  -- ^ Should we dump detailed build information for this component?+  -> PackageDescription+  -- ^ Mostly information from the .cabal file+  -> LocalBuildInfo+  -- ^ Configuration information+  -> BuildFlags+  -- ^ Flags that the user passed to build+  -> IO ()+dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do+  when shouldDumpBuildInfo $ do+    -- Changing this line might break consumers of the dumped build info.+    -- Announce changes on mailing lists!+    let activeTargets = allTargetsInBuildOrder' pkg_descr lbi+    info verbosity $+      "Dump build information for: "+        ++ intercalate+          ", "+          ( map+              (showComponentName . componentLocalName . targetCLBI)+              activeTargets+          )++    (compilerProg, _) <- case flavorToProgram (compilerFlavor (compiler lbi)) of+      Nothing ->+        dieWithException verbosity $ UnknownCompilerFlavor (compilerFlavor (compiler lbi))+      Just program -> requireProgram verbosity program (withPrograms lbi)++    wdir <- absoluteWorkingDirLBI lbi+    let (warns, json) = mkBuildInfo wdir pkg_descr lbi flags (compilerProg, compiler lbi) activeTargets+        buildInfoText = renderJson json+    unless (null warns) $+      warn verbosity $+        "Encountered warnings while dumping build-info:\n"+          ++ unlines warns+    LBS.writeFile buildInfoFile buildInfoText++  when (not shouldDumpBuildInfo) $ do+    -- Remove existing build-info.json as it might be outdated now.+    exists <- doesFileExist buildInfoFile+    when exists $ removeFile buildInfoFile+  where+    buildInfoFile = interpretSymbolicPathLBI lbi $ buildInfoPref distPref+    shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo++    -- \| Given the flavor of the compiler, try to find out+    -- which program we need.+    flavorToProgram :: CompilerFlavor -> Maybe Program+    flavorToProgram GHC = Just ghcProgram+    flavorToProgram GHCJS = Just ghcjsProgram+    flavorToProgram UHC = Just uhcProgram+    flavorToProgram JHC = Just jhcProgram+    flavorToProgram _ = Nothing++repl+  :: PackageDescription+  -- ^ Mostly information from the .cabal file+  -> LocalBuildInfo+  -- ^ Configuration information+  -> ReplFlags+  -- ^ Flags that the user passed to build+  -> [PPSuffixHandler]+  -- ^ preprocessors to run before compiling+  -> [String]+  -> IO ()+repl = repl_setupHooks noBuildHooks++repl_setupHooks+  :: BuildHooks+  -- ^ build hook+  -> PackageDescription+  -- ^ Mostly information from the .cabal file+  -> LocalBuildInfo+  -- ^ Configuration information+  -> ReplFlags+  -- ^ Flags that the user passed to build+  -> [PPSuffixHandler]+  -- ^ preprocessors to run before compiling+  -> [String]+  -> IO ()+repl_setupHooks+  (BuildHooks{preBuildComponentRules = mbPbcRules})+  pkg_descr+  lbi+  flags+  suffixHandlers+  args = do+    let distPref = fromFlag (replDistPref flags)+        verbosity = fromFlag (replVerbosity flags)++    target <-+      readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of+        -- This seems DEEPLY questionable.+        [] -> case allTargetsInBuildOrder' pkg_descr lbi of+          (target : _) -> return target+          [] -> dieWithException verbosity $ FailedToDetermineTarget+        [target] -> return target+        _ -> dieWithException verbosity $ NoMultipleTargets+    let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target]+    debug verbosity $+      "Component build order: "+        ++ intercalate+          ", "+          ( map+              (showComponentName . componentLocalName . targetCLBI)+              componentsToBuild+          )++    internalPackageDB <- createInternalPackageDB verbosity lbi distPref++    let lbiForComponent comp lbi' = do+          curDir <- absoluteWorkingDirLBI lbi'+          return $+            lbi'+              { withPackageDB = withPackageDB lbi' ++ [internalPackageDB]+              , withPrograms =+                  -- Include any build-tool-depends on build tools internal to the current package.+                  addInternalBuildTools+                    curDir+                    pkg_descr+                    lbi'+                    (componentBuildInfo comp)+                    (withPrograms lbi')+              }+        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++    -- build any dependent components+    sequence_+      [ do+        let clbi = targetCLBI subtarget+            comp = targetComponent subtarget+        lbi' <- lbiForComponent comp lbi+        preBuildComponent runPreBuildHooks verbosity lbi' subtarget+        buildComponent+          (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag verbosity}})+          NoFlag+          pkg_descr+          lbi'+          suffixHandlers+          comp+          clbi+          distPref+      | subtarget <- safeInit componentsToBuild+      ]++    -- REPL for target components+    let clbi = targetCLBI target+        comp = targetComponent target+    lbi' <- lbiForComponent comp lbi+    preBuildComponent runPreBuildHooks verbosity lbi' target+    replComponent flags verbosity pkg_descr lbi' suffixHandlers comp clbi distPref++-- | Start an interpreter without loading any package files.+startInterpreter+  :: Verbosity+  -> ProgramDb+  -> Compiler+  -> Platform+  -> PackageDBStack+  -> IO ()+startInterpreter verbosity programDb comp platform packageDBs =+  case compilerFlavor comp of+    GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs+    GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs+    _ -> dieWithException verbosity REPLNotSupported++buildComponent+  :: BuildFlags+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> [PPSuffixHandler]+  -> Component+  -> ComponentLocalBuildInfo+  -> SymbolicPath Pkg (Dir Dist)+  -> IO (Maybe InstalledPackageInfo)+buildComponent flags _ _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ =+  dieWithException (fromFlag $ buildVerbosity flags) $+    NoSupportBuildingTestSuite tt+buildComponent flags _ _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ =+  dieWithException (fromFlag $ buildVerbosity flags) $+    NoSupportBuildingBenchMark tt+buildComponent+  flags+  numJobs+  pkg_descr+  lbi0+  suffixHandlers+  comp@( CTest+          test@TestSuite{testInterface = TestSuiteLibV09{}}+        )+  clbi -- This ComponentLocalBuildInfo corresponds to a detailed+  -- test suite and not a real component. It should not+  -- be used, except to construct the CLBIs for the+  -- library and stub executable that will actually be+  -- built.+  distPref =+    do+      inplaceDir <- absoluteWorkingDirLBI lbi0+      let verbosity = 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+      extras <- preprocessExtras verbosity comp lbi -- TODO find cpphs processed files+      (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity+      setupMessage'+        verbosity+        "Building"+        (packageId pkg_descr)+        (componentLocalName clbi)+        (maybeComponentInstantiatedWith clbi)+      let libbi = libBuildInfo lib+          lib' = lib{libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir}+      buildLib 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.+      registerPackage+        verbosity+        (compiler lbi)+        (withPrograms lbi)+        (mbWorkDirLBI lbi)+        (withPackageDB lbi)+        ipi+        HcPkg.defaultRegisterOptions+          { HcPkg.registerMultiInstance = True+          }+      let ebi = buildInfo exe+          -- NB: The stub executable is linked against the test-library+          --     which already contains all `other-modules`, so we need+          --     to remove those from the stub-exe's build-info+          exe' = exe{buildInfo = (addExtraCSources ebi extras){otherModules = []}}+      buildExe verbosity numJobs pkg_descr lbi exe' exeClbi+      return Nothing -- Can't depend on test suite+buildComponent+  flags+  numJobs+  pkg_descr+  lbi+  suffixHandlers+  comp+  clbi+  distPref =+    do+      let verbosity = fromFlag $ buildVerbosity flags+      preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers+      extras <- preprocessExtras verbosity comp lbi+      setupMessage'+        verbosity+        "Building"+        (packageId pkg_descr)+        (componentLocalName clbi)+        (maybeComponentInstantiatedWith clbi)+      case comp of+        CLib lib -> do+          let libbi = libBuildInfo lib+              lib' =+                lib+                  { libBuildInfo =+                      flip addExtraAsmSources extras $+                        flip addExtraCmmSources extras $+                          flip addExtraCxxSources extras $+                            flip addExtraCSources extras $+                              flip addExtraJsSources extras $+                                libbi+                  }++          buildLib 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)))+            then do+              -- Register the library in-place, so exes can depend+              -- on internally defined libraries.+              inplaceDir <- absoluteWorkingDirLBI lbi+              let+                -- The in place registration uses the "-inplace" suffix, not an ABI hash+                installedPkgInfo =+                  inplaceInstalledPackageInfo+                    inplaceDir+                    distPref+                    pkg_descr+                    -- NB: Use a fake ABI hash to avoid+                    -- needing to recompute it every build.+                    (mkAbiHash "inplace")+                    lib'+                    lbi+                    clbi+              debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo)+              registerPackage+                verbosity+                (compiler lbi)+                (withPrograms lbi)+                (flagToMaybe $ buildWorkingDir flags)+                (withPackageDB lbi)+                installedPkgInfo+                HcPkg.defaultRegisterOptions+                  { HcPkg.registerMultiInstance = True+                  }+              return (Just installedPkgInfo)+            else return Nothing+        CFLib flib -> do+          buildFLib verbosity numJobs pkg_descr lbi flib clbi+          return Nothing+        CExe exe -> do+          let ebi = buildInfo exe+              exe' = exe{buildInfo = addExtraCSources ebi extras}+          buildExe verbosity numJobs pkg_descr lbi exe' clbi+          return Nothing+        CTest test@TestSuite{testInterface = TestSuiteExeV10{}} -> do+          let exe = testSuiteExeV10AsExe test+          (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity+          let ebi = buildInfo exe+              exe' = exe{buildInfo = addSrcDir (addExtraOtherModules (addExtraCSources ebi extras) generatedExtras) genDir} -- todo extend hssrcdirs+          buildExe verbosity numJobs pkg_descr lbi exe' clbi+          return Nothing+        CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}} -> do+          let exe = benchmarkExeV10asExe bm+          let ebi = buildInfo exe+              exe' = exe{buildInfo = addExtraCSources ebi extras}+          buildExe verbosity numJobs pkg_descr lbi exe' clbi+          return Nothing+#if __GLASGOW_HASKELL__ < 811+-- silence pattern-match warnings prior to GHC 9.0+        _ -> error "impossible"+#endif++generateCode+  :: [String]+  -> UnqualComponentName+  -> PackageDescription+  -> BuildInfo+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> 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+  where+    allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc)+    dependencyLibs = filter (const True) allLibs -- intersect with componentPackageDeps of clbi+    srcDirs = concatMap (hsSourceDirs . libBuildInfo) dependencyLibs+    nm' = unUnqualComponentName nm+    mbWorkDir = mbWorkDirLBI lbi+    i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path+    tgtDir = buildDir lbi </> makeRelativePathEx (nm' </> nm' ++ "-gen")+    go :: String -> IO [ModuleName.ModuleName]+    go codeGenProg =+      fmap fromString . lines+        <$> getDbProgramOutputCwd+          verbosity+          mbWorkDir+          (simpleProgram codeGenProg)+          (withPrograms lbi)+          ( map interpretSymbolicPathCWD (tgtDir : srcDirs)+              ++ ( "--"+                    : GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbosity lbi bi clbi tgtDir)+                 )+          )++-- | Add extra C sources generated by preprocessing to build+-- information.+addExtraCSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo+addExtraCSources bi extras = bi{cSources = new}+  where+    new = ordNub (extras ++ cSources bi)++-- | Add extra C++ sources generated by preprocessing to build+-- information.+addExtraCxxSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo+addExtraCxxSources bi extras = bi{cxxSources = new}+  where+    new = ordNub (extras ++ cxxSources bi)++-- | Add extra C-- sources generated by preprocessing to build+-- information.+addExtraCmmSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo+addExtraCmmSources bi extras = bi{cmmSources = new}+  where+    new = ordNub (extras ++ cmmSources bi)++-- | Add extra ASM sources generated by preprocessing to build+-- information.+addExtraAsmSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo+addExtraAsmSources bi extras = bi{asmSources = new}+  where+    new = ordNub (extras ++ asmSources bi)++-- | Add extra JS sources generated by preprocessing to build+-- information.+addExtraJsSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo+addExtraJsSources bi extras = bi{jsSources = new}+  where+    new = ordNub (extras ++ jsSources bi)++-- | Add extra HS modules generated by preprocessing to build+-- information.+addExtraOtherModules :: BuildInfo -> [ModuleName.ModuleName] -> BuildInfo+addExtraOtherModules bi extras = bi{otherModules = new}+  where+    new = ordNub (extras ++ otherModules bi)++-- | Add extra source dir for generated modules.+addSrcDir :: BuildInfo -> SymbolicPath Pkg (Dir Source) -> BuildInfo+addSrcDir bi extra = bi{hsSourceDirs = new}+  where+    new = ordNub (extra : hsSourceDirs bi)++replComponent+  :: ReplFlags+  -> Verbosity+  -> PackageDescription+  -> LocalBuildInfo+  -> [PPSuffixHandler]+  -> Component+  -> ComponentLocalBuildInfo+  -> SymbolicPath Pkg (Dir Dist)+  -> IO ()+replComponent _ verbosity _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ =+  dieWithException verbosity $ NoSupportBuildingTestSuite tt+replComponent _ verbosity _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ =+  dieWithException verbosity $ NoSupportBuildingBenchMark tt+replComponent+  replFlags+  verbosity+  pkg_descr+  lbi0+  suffixHandlers+  comp@( CTest+          test@TestSuite{testInterface = TestSuiteLibV09{}}+        )+  clbi+  distPref = do+    inplaceDir <- absoluteWorkingDirLBI lbi0+    let (pkg, lib, libClbi, lbi, _, _, _) =+          testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 inplaceDir distPref+    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers+    extras <- preprocessExtras verbosity comp lbi+    let libbi = libBuildInfo lib+        lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}}+    replLib replFlags pkg lbi lib' libClbi+replComponent+  replFlags+  verbosity+  pkg_descr+  lbi+  suffixHandlers+  comp+  clbi+  _ =+    do+      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+        CFLib flib ->+          replFLib 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+        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+        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+#if __GLASGOW_HASKELL__ < 811+-- silence pattern-match warnings prior to GHC 9.0+        _ -> error "impossible"+#endif++----------------------------------------------------+-- Shared code for buildComponent and replComponent+--++-- | Translate a exe-style 'TestSuite' component into an exe for building+testSuiteExeV10AsExe :: TestSuite -> Executable+testSuiteExeV10AsExe test@TestSuite{testInterface = TestSuiteExeV10 _ mainFile} =+  Executable+    { exeName = testName test+    , modulePath = mainFile+    , exeScope = ExecutablePublic+    , buildInfo = testBuildInfo test+    }+testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind"++-- | Translate a exe-style 'Benchmark' component into an exe for building+benchmarkExeV10asExe :: Benchmark -> Executable+benchmarkExeV10asExe bm@Benchmark{benchmarkInterface = BenchmarkExeV10 _ mainFile} =+  Executable+    { exeName = benchmarkName bm+    , modulePath = mainFile+    , exeScope = ExecutablePublic+    , buildInfo = benchmarkBuildInfo bm+    }+benchmarkExeV10asExe Benchmark{} = error "benchmarkExeV10asExe: wrong kind"++-- | Translate a lib-style 'TestSuite' component into a lib + exe for building+testSuiteLibV09AsLibAndExe+  :: PackageDescription+  -> TestSuite+  -> ComponentLocalBuildInfo+  -> LocalBuildInfo+  -> AbsolutePath (Dir Pkg)+  -- ^ absolute inplace dir+  -> SymbolicPath Pkg (Dir Dist)+  -> ( PackageDescription+     , Library+     , ComponentLocalBuildInfo+     , LocalBuildInfo+     , IPI.InstalledPackageInfo+     , Executable+     , ComponentLocalBuildInfo+     )+testSuiteLibV09AsLibAndExe+  pkg_descr+  test@TestSuite{testInterface = TestSuiteLibV09 _ m}+  clbi+  lbi+  inplaceDir+  distPref =+    (pkg, lib, libClbi, lbi, ipi, exe, exeClbi)+    where+      bi = testBuildInfo test+      lib =+        Library+          { libName = LMainLibName+          , exposedModules = [m]+          , reexportedModules = []+          , signatures = []+          , libExposed = True+          , libVisibility = LibraryVisibilityPrivate+          , libBuildInfo = bi+          }+      -- This is, like, the one place where we use a CTestName for a library.+      -- Should NOT use library name, since that could conflict!+      PackageIdentifier pkg_name pkg_ver = package pkg_descr+      -- Note: we do make internal library from the test!+      compat_name = MungedPackageName pkg_name (LSubLibName (testName test))+      compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi)+      libClbi =+        LibComponentLocalBuildInfo+          { componentPackageDeps = componentPackageDeps clbi+          , componentInternalDeps = componentInternalDeps clbi+          , componentIsIndefinite_ = False+          , componentExeDeps = componentExeDeps clbi+          , componentLocalName = CLibName $ LSubLibName $ testName test+          , componentIsPublic = False+          , componentIncludes = componentIncludes clbi+          , componentUnitId = componentUnitId clbi+          , componentComponentId = componentComponentId clbi+          , componentInstantiatedWith = []+          , componentCompatPackageName = compat_name+          , componentCompatPackageKey = compat_key+          , componentExposedModules = [IPI.ExposedModule m Nothing]+          }+      pkgName' = mkPackageName $ prettyShow compat_name+      pkg =+        pkg_descr+          { package = (package pkg_descr){pkgName = pkgName'}+          , executables = []+          , testSuites = []+          , subLibraries = [lib]+          }+      ipi = inplaceInstalledPackageInfo inplaceDir distPref pkg (mkAbiHash "") lib lbi libClbi+      testLibDep =+        Dependency+          pkgName'+          (thisVersion $ pkgVersion $ package pkg_descr)+          mainLibSet+      exe =+        Executable+          { exeName = mkUnqualComponentName $ stubName test+          , modulePath = makeRelativePathEx $ stubFilePath test+          , exeScope = ExecutablePublic+          , buildInfo =+              (testBuildInfo test)+                { hsSourceDirs = [coerceSymbolicPath $ testBuildDir lbi test]+                , targetBuildDepends =+                    testLibDep+                      : targetBuildDepends (testBuildInfo test)+                }+          }+      -- \| The stub executable needs a new 'ComponentLocalBuildInfo'+      -- that exposes the relevant test suite library.+      deps =+        (IPI.installedUnitId ipi, mungedId ipi)+          : ( filter+                ( \(_, x) ->+                    let name = prettyShow $ mungedName x+                     in name == "Cabal" || name == "base"+                )+                (componentPackageDeps clbi)+            )+      exeClbi =+        ExeComponentLocalBuildInfo+          { -- TODO: this is a hack, but as long as this is unique+            -- (doesn't clobber something) we won't run into trouble+            componentUnitId = mkUnitId (stubName test)+          , componentComponentId = mkComponentId (stubName test)+          , componentInternalDeps = [componentUnitId clbi]+          , componentExeDeps = []+          , componentLocalName = CExeName $ mkUnqualComponentName $ stubName test+          , componentPackageDeps = deps+          , -- Assert DefUnitId invariant!+            -- Executable can't be indefinite, so dependencies must+            -- be definite packages.+            componentIncludes =+              map ((,defaultRenaming) . DefiniteUnitId . unsafeMkDefUnitId . fst) deps+          }+testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"++-- | Initialize a new package db file for libraries defined+-- internally to the package.+createInternalPackageDB+  :: Verbosity+  -> LocalBuildInfo+  -> SymbolicPath Pkg (Dir Dist)+  -> IO PackageDB+createInternalPackageDB verbosity lbi distPref = do+  existsAlready <- doesPackageDBExist dbPath+  when existsAlready $ deletePackageDB dbPath+  createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath+  return (SpecificPackageDB dbRelPath)+  where+    dbRelPath = internalPackageDBPath lbi distPref+    dbPath = interpretSymbolicPathLBI lbi dbRelPath++-- | Update the program database to include any build-tool-depends specified+-- in the given 'BuildInfo' on build tools internal to the current package.+--+-- This function:+--+--  - adds these internal build tools to the 'ProgramDb', including+--    paths to their respective data directories,+--  - adds their paths to the current 'progSearchPath', and adds the data+--    directory environment variable for the current package to the current+--    'progOverrideEnv', so that any programs configured from now on will be+--    able to invoke these build tools.+addInternalBuildTools+  :: AbsolutePath (Dir Pkg)+  -> PackageDescription+  -> LocalBuildInfo+  -> BuildInfo+  -> ProgramDb+  -> ProgramDb+addInternalBuildTools pwd pkg lbi bi progs =+  prependProgramSearchPathNoLogging+    internalToolPaths+    [pkgDataDirVar]+    $ foldr updateProgram progs internalBuildTools+  where+    internalToolPaths = map (takeDirectory . programPath) internalBuildTools+    pkgDataDirVar = (pkgPathEnvVar pkg "datadir", Just dataDirPath)+    internalBuildTools =+      [ (simpleConfiguredProgram toolName' (FoundOnSystem toolLocation))+        { programOverrideEnv = [pkgDataDirVar]+        }+      | toolName <- getAllInternalToolDependencies pkg bi+      , let toolName' = unUnqualComponentName toolName+      , let toolLocation =+              interpretSymbolicPathLBI lbi $+                buildDir lbi+                  </> makeRelativePathEx (toolName' </> toolName' <.> exeExtension (hostPlatform lbi))+      ]++    -- This is an absolute path, so if a process changes directory, it can still+    -- find the datadir (#10717)+    dataDirPath :: FilePath+    dataDirPath = interpretSymbolicPathAbsolute pwd (dataDir pkg)++-- TODO: build separate libs in separate dirs so that we can build+-- multiple libs, e.g. for 'LibTest' library-style test suites+buildLib+  :: BuildFlags+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> Library+  -> ComponentLocalBuildInfo+  -> IO ()+buildLib flags numJobs pkg_descr lbi lib clbi =+  let verbosity = fromFlag $ buildVerbosity flags+   in case compilerFlavor (compiler lbi) of+        GHC -> GHC.buildLib 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+        _ -> dieWithException verbosity BuildingNotSupportedWithCompiler++-- | Build a foreign library+--+-- NOTE: We assume that we already checked that we can actually build the+-- foreign library in configure.+buildFLib+  :: Verbosity+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> ForeignLib+  -> ComponentLocalBuildInfo+  -> IO ()+buildFLib verbosity numJobs pkg_descr lbi flib clbi =+  case compilerFlavor (compiler lbi) of+    GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi+    _ -> dieWithException verbosity BuildingNotSupportedWithCompiler++buildExe+  :: Verbosity+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> Executable+  -> ComponentLocalBuildInfo+  -> IO ()+buildExe verbosity numJobs pkg_descr lbi exe clbi =+  case compilerFlavor (compiler lbi) of+    GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi+    GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi+    UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi+    _ -> dieWithException verbosity BuildingNotSupportedWithCompiler++replLib+  :: ReplFlags+  -> PackageDescription+  -> LocalBuildInfo+  -> Library+  -> ComponentLocalBuildInfo+  -> IO ()+replLib replFlags pkg_descr lbi lib clbi =+  let verbosity = 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+        GHCJS -> GHCJS.replLib (replOptionsFlags opts) verbosity NoFlag pkg_descr lbi lib clbi+        _ -> dieWithException verbosity REPLNotSupported++replExe+  :: ReplFlags+  -> PackageDescription+  -> LocalBuildInfo+  -> Executable+  -> ComponentLocalBuildInfo+  -> IO ()+replExe flags pkg_descr lbi exe clbi =+  let verbosity = fromFlag $ replVerbosity flags+   in case compilerFlavor (compiler lbi) of+        GHC -> GHC.replExe flags NoFlag pkg_descr lbi exe clbi+        GHCJS ->+          GHCJS.replExe+            (replOptionsFlags $ replReplOptions flags)+            verbosity+            NoFlag+            pkg_descr+            lbi+            exe+            clbi+        _ -> dieWithException verbosity REPLNotSupported++replFLib+  :: ReplFlags+  -> PackageDescription+  -> LocalBuildInfo+  -> ForeignLib+  -> ComponentLocalBuildInfo+  -> IO ()+replFLib flags pkg_descr lbi exe clbi =+  let verbosity = fromFlag $ replVerbosity flags+   in case compilerFlavor (compiler lbi) of+        GHC -> GHC.replFLib flags NoFlag pkg_descr lbi exe clbi+        _ -> dieWithException verbosity REPLNotSupported++-- | Runs 'componentInitialBuildSteps' on every configured component.+--+-- Legacy function: does not run pre-build hooks or pre-processors. This function+-- is insufficient on its own to prepare the build for a package.+--+-- Consumers wanting to prepare the sources of a package, e.g. in order to+-- launch a REPL session, are advised to run @Setup repl --repl-multi-file=<fn>@+-- instead.+initialBuildSteps+  :: FilePath+  -- ^ "dist" prefix+  -> PackageDescription+  -- ^ mostly information from the .cabal file+  -> LocalBuildInfo+  -- ^ Configuration information+  -> Verbosity+  -- ^ The verbosity to use+  -> IO ()+initialBuildSteps distPref pkg_descr lbi verbosity =+  withAllComponentsInBuildOrder pkg_descr lbi $ \_comp clbi ->+    componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity+{-# DEPRECATED+  initialBuildSteps+  "This function does not prepare all source files for a package. Suggestion: use 'Setup repl --repl-multi-file=<fn>'."+  #-}++-- | Creates the autogenerated files for a particular configured component.+--+-- Legacy function: does not run pre-build hooks or pre-processors. This function+-- is insufficient on its own to prepare the build for a component.+--+-- Consumers wanting to prepare the sources of a component, e.g. in order to+-- launch a REPL session, are advised to run+-- @Setup repl <compName> --repl-multi-file=<fn>@ instead.+componentInitialBuildSteps+  :: FilePath+  -- ^ "dist" prefix+  -> PackageDescription+  -- ^ mostly information from the .cabal file+  -> LocalBuildInfo+  -- ^ Configuration information+  -> ComponentLocalBuildInfo+  -- ^ Build info about the component+  -> Verbosity+  -- ^ The verbosity to use+  -> IO ()+componentInitialBuildSteps _distPref pkg_descr lbi clbi verbosity = do+  let compBuildDir = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi+  createDirectoryIfMissingVerbose verbosity True compBuildDir+  writeBuiltinAutogenFiles verbosity pkg_descr lbi clbi+{-# DEPRECATED+  componentInitialBuildSteps+  "This function does not prepare all source files for a component. Suggestion: use 'Setup repl <compName> --repl-multi-file=<fn>'."+  #-}++-- | Creates the autogenerated files for a particular configured component,+-- and runs the pre-build hook.+preBuildComponent+  :: (LocalBuildInfo -> TargetInfo -> IO ())+  -- ^ pre-build hook+  -> Verbosity+  -> LocalBuildInfo+  -- ^ Configuration information+  -> TargetInfo+  -> IO ()+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++-- | 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+-- (see 'autogenComponentsModuleDir').+--+-- This includes:+--+--  - @Paths_<pkg>.hs@,+--  - @PackageInfo_<pkg>.hs@,+--  - Backpack signature files for components that are not fully instantiated,+--  - @cabal_macros.h@.+writeBuiltinAutogenFiles+  :: Verbosity+  -> PackageDescription+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> IO ()+writeBuiltinAutogenFiles verbosity pkg lbi clbi =+  writeAutogenFiles verbosity lbi clbi $ builtinAutogenFiles pkg lbi clbi++-- | Built-in autogenerated files and their contents. This includes:+--+--  - @Paths_<pkg>.hs@,+--  - @PackageInfo_<pkg>.hs@,+--  - Backpack signature files for components that are not fully instantiated,+--  - @cabal_macros.h@.+builtinAutogenFiles+  :: PackageDescription+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> Map AutogenFile AutogenFileContents+builtinAutogenFiles pkg lbi clbi =+  Map.insert pathsFile pathsContents $+    Map.insert packageInfoFile packageInfoContents $+      Map.insert cppHeaderFile cppHeaderContents $+        emptySignatureModules clbi+  where+    pathsFile = AutogenModule (autogenPathsModuleName pkg) (Suffix "hs")+    pathsContents = toUTF8LBS $ generatePathsModule pkg lbi clbi+    packageInfoFile = AutogenModule (autogenPackageInfoModuleName pkg) (Suffix "hs")+    packageInfoContents = toUTF8LBS $ generatePackageInfoModule pkg lbi+    cppHeaderFile = AutogenFile $ toShortText cppHeaderName+    cppHeaderContents = toUTF8LBS $ generateCabalMacrosHeader pkg lbi clbi++-- | An empty @".hsig"@ Backpack signature module for each requirement, so that+-- GHC has a source file to look at it when it needs to typecheck+-- a signature.  It's harmless to generate these modules, even when+-- there is a real @hsig@ file written by the user, since+-- include path ordering ensures that the real @hsig@ file+-- will always be picked up before the autogenerated one.+emptySignatureModules+  :: ComponentLocalBuildInfo+  -> Map AutogenFile AutogenFileContents+emptySignatureModules clbi =+  case clbi of+    LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->+      Map.fromList+        [ ( AutogenModule modName (Suffix "hsig")+          , emptyHsigFile modName+          )+        | (modName, _) <- insts+        ]+    _ -> Map.empty+  where+    emptyHsigFile :: ModuleName -> AutogenFileContents+    emptyHsigFile modName =+      toUTF8LBS $+        "{-# OPTIONS_GHC -w #-}\n"+          ++ "{-# LANGUAGE NoImplicitPrelude #-}\n"+          ++ "signature "+          ++ prettyShow modName+          ++ " where"++data AutogenFile+  = AutogenModule !ModuleName !Suffix+  | AutogenFile !ShortText+  deriving (Show, Eq, Ord)++-- | A representation of the contents of an autogenerated file.+type AutogenFileContents = LBS.ByteString++-- | Write the given autogenerated files in the autogenerated modules+-- directory for the component.+writeAutogenFiles+  :: Verbosity+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> Map AutogenFile AutogenFileContents+  -> IO ()+writeAutogenFiles verbosity lbi clbi autogenFiles = do+  -- Ensure that the overall autogenerated files directory exists.+  createDirectoryIfMissingVerbose verbosity True autogenDir+  for_ (Map.assocs autogenFiles) $ \(file, contents) -> do+    let path = case file of+          AutogenModule modName (Suffix ext) ->+            autogenDir </> ModuleName.toFilePath modName <.> ext+          AutogenFile fileName ->+            autogenDir </> fromShortText fileName+        dir = takeDirectory path+    -- Ensure that the directory subtree for this autogenerated file exists.+    createDirectoryIfMissingVerbose verbosity True dir+    -- Write the contents of the file.+    rewriteFileLBS verbosity path contents+  where+    autogenDir = interpretSymbolicPathLBI lbi $ autogenComponentModulesDir lbi clbi
+ src/Distribution/Simple/Build/Inputs.hs view
@@ -0,0 +1,74 @@+module Distribution.Simple.Build.Inputs+  ( -- * Inputs of actions for building components+    PreBuildComponentInputs (..)++    -- * Queries over the component being built+  , buildVerbosity+  , buildComponent+  , buildIsLib+  , buildCLBI+  , buildBI+  , buildCompiler++    -- * Re-exports+  , BuildingWhat (..)+  , LocalBuildInfo (..)+  , TargetInfo (..)+  , buildingWhatCommonFlags+  , buildingWhatVerbosity+  , buildingWhatWorkingDir+  , buildingWhatDistPref+  )+where++import Distribution.Simple.Compiler+import Distribution.Simple.Setup hiding+  ( BuildFlags (buildVerbosity)+  )+import Distribution.Types.BuildInfo+import Distribution.Types.Component+import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.LocalBuildInfo+import Distribution.Types.TargetInfo+import Distribution.Verbosity++-- | The information required for a build computation which is available right+-- before building each component, i.e. the pre-build component inputs.+data PreBuildComponentInputs = PreBuildComponentInputs+  { buildingWhat :: BuildingWhat+  -- ^ What kind of build are we doing?+  , localBuildInfo :: LocalBuildInfo+  -- ^ Information about the package+  , targetInfo :: TargetInfo+  -- ^ Information about an individual component+  }++-- | Get the @'Verbosity'@ from the context the component being built is in.+buildVerbosity :: PreBuildComponentInputs -> Verbosity+buildVerbosity = buildingWhatVerbosity . buildingWhat++-- | Get the @'Component'@ being built.+buildComponent :: PreBuildComponentInputs -> Component+buildComponent = targetComponent . targetInfo++-- | Is the @'Component'@ being built a @'Library'@?+buildIsLib :: PreBuildComponentInputs -> Bool+buildIsLib = do+  component <- buildComponent+  let isLib+        | CLib{} <- component = True+        | otherwise = False+  return isLib+{-# INLINE buildIsLib #-}++-- | Get the @'ComponentLocalBuildInfo'@ for the component being built.+buildCLBI :: PreBuildComponentInputs -> ComponentLocalBuildInfo+buildCLBI = targetCLBI . targetInfo++-- | Get the @'BuildInfo'@ of the component being built.+buildBI :: PreBuildComponentInputs -> BuildInfo+buildBI = componentBuildInfo . buildComponent++-- | Get the @'Compiler'@ being used to build the component.+buildCompiler :: PreBuildComponentInputs -> Compiler+buildCompiler = compiler . localBuildInfo
src/Distribution/Simple/Build/Macros.hs view
@@ -1,4 +1,5 @@ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Build.Macros -- Copyright   :  Simon Marlow 2008@@ -18,93 +19,96 @@ -- numbers. -- -- TODO Figure out what to do about backpack and internal libraries. It is very--- suspecious that this stuff works with munged package identifiers-module Distribution.Simple.Build.Macros (-    generateCabalMacrosHeader,-    generatePackageVersionMacros,+-- suspicious that this stuff works with munged package identifiers+module Distribution.Simple.Build.Macros+  ( generateCabalMacrosHeader+  , generatePackageVersionMacros   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Version import Distribution.PackageDescription+import Distribution.Pretty import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program.Db import Distribution.Simple.Program.Types import Distribution.Types.MungedPackageId import Distribution.Types.MungedPackageName-import Distribution.Pretty+import Distribution.Version  import qualified Distribution.Simple.Build.Macros.Z as Z  -- | The contents of the @cabal_macros.h@ for the given configured package.--- generateCabalMacrosHeader :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String-generateCabalMacrosHeader pkg_descr lbi clbi = Z.render Z.Z-    { Z.zPackages        = map mkZPackage $ package pkg_descr : map getPid (componentPackageDeps clbi)-    , Z.zTools           =-        [ Z.ZTool-            { Z.ztoolName    = programId prog+generateCabalMacrosHeader pkg_descr lbi clbi =+  Z.render+    Z.Z+      { Z.zPackages = map mkZPackage $ package pkg_descr : map getPid (componentPackageDeps clbi)+      , Z.zTools =+          [ Z.ZTool+            { Z.ztoolName = programId prog             , Z.ztoolVersion = ver-            , Z.ztoolX       = major1-            , Z.ztoolY       = major2-            , Z.ztoolZ       = minor+            , Z.ztoolX = major1+            , Z.ztoolY = major2+            , Z.ztoolZ = minor             }-        | prog <- configuredPrograms $ withPrograms lbi-        , ver <- maybeToList (programVersion prog)-        , let (major1,major2,minor) = majorMinor ver-        ]-    , Z.zPackageKey      = case clbi of-        LibComponentLocalBuildInfo{} -> componentCompatPackageKey clbi-        _                            -> ""-    , Z.zComponentId     = prettyShow (componentComponentId clbi)-    , Z.zPackageVersion  = pkgVersion (package pkg_descr)-    , Z.zNotNull         = not . null-    , Z.zManglePkgName   = map fixchar . unPackageName-    , Z.zMangleStr       = map fixchar-    }+          | prog <- configuredPrograms $ withPrograms lbi+          , ver <- maybeToList (programVersion prog)+          , let (major1, major2, minor) = majorMinor ver+          ]+      , Z.zPackageKey = case clbi of+          LibComponentLocalBuildInfo{componentCompatPackageKey = compatPackageKey} -> compatPackageKey+          _ -> ""+      , Z.zComponentId = prettyShow (componentComponentId clbi)+      , Z.zPackageVersion = pkgVersion (package pkg_descr)+      , Z.zNotNull = not . null+      , Z.zManglePkgName = map fixchar . unPackageName+      , Z.zMangleStr = map fixchar+      }   where     getPid (_, MungedPackageId (MungedPackageName pn _) v) =-       -- NB: Drop the library name! We're just reporting package versions.-       -- This would have to be revisited if you are allowed to depend-       -- on different versions of the same package-        PackageIdentifier pn v+      -- NB: Drop the library name! We're just reporting package versions.+      -- This would have to be revisited if you are allowed to depend+      -- on different versions of the same package+      PackageIdentifier pn v  -- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@ -- macros for a list of package ids (usually used with the specific deps of -- a configured package).--- generatePackageVersionMacros :: Version -> [PackageId] -> String-generatePackageVersionMacros ver pkgids = Z.render Z.Z-    { Z.zPackages        = map mkZPackage pkgids-    , Z.zTools           = []-    , Z.zPackageKey      = ""-    , Z.zComponentId     = ""-    , Z.zPackageVersion  = ver-    , Z.zNotNull         = not . null-    , Z.zManglePkgName   = map fixchar . unPackageName-    , Z.zMangleStr       = map fixchar-    }+generatePackageVersionMacros ver pkgids =+  Z.render+    Z.Z+      { Z.zPackages = map mkZPackage pkgids+      , Z.zTools = []+      , Z.zPackageKey = ""+      , Z.zComponentId = ""+      , Z.zPackageVersion = ver+      , Z.zNotNull = not . null+      , Z.zManglePkgName = map fixchar . unPackageName+      , Z.zMangleStr = map fixchar+      }  mkZPackage :: PackageId -> Z.ZPackage-mkZPackage (PackageIdentifier name ver) = Z.ZPackage-    { Z.zpkgName    = name+mkZPackage (PackageIdentifier name ver) =+  Z.ZPackage+    { Z.zpkgName = name     , Z.zpkgVersion = ver-    , Z.zpkgX       = major1-    , Z.zpkgY       = major2-    , Z.zpkgZ       = minor+    , Z.zpkgX = major1+    , Z.zpkgY = major2+    , Z.zpkgZ = minor     }   where-    (major1,major2,minor) = majorMinor ver+    (major1, major2, minor) = majorMinor ver  majorMinor :: Version -> (String, String, String) majorMinor ver = case map show (versionNumbers ver) of-        []        -> ("0", "0", "0")-        [x]       -> (x,   "0", "0")-        [x,y]     -> (x,   y,   "0")-        (x:y:z:_) -> (x,   y,   z)+  [] -> ("0", "0", "0")+  [x] -> (x, "0", "0")+  [x, y] -> (x, y, "0")+  (x : y : z : _) -> (x, y, z)  fixchar :: Char -> Char fixchar '-' = '_'-fixchar c   = c+fixchar c = c
src/Distribution/Simple/Build/Macros/Z.hs view
@@ -1,9 +1,10 @@+{- FOURMOLU_DISABLE -} {-# LANGUAGE DeriveGeneric #-} module Distribution.Simple.Build.Macros.Z (render, Z(..), ZPackage (..), ZTool (..)) where import Distribution.ZinzaPrelude data Z-    = Z {zPackages :: ([ZPackage]),-         zTools :: ([ZTool]),+    = Z {zPackages :: [ZPackage],+         zTools :: [ZTool],          zPackageKey :: String,          zComponentId :: String,          zPackageVersion :: Version,
+ src/Distribution/Simple/Build/PackageInfoModule.hs view
@@ -0,0 +1,60 @@+-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Build.PackageInfoModule+-- Copyright   :+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Generating the PackageInfo_pkgname module.+--+-- This is a module that Cabal generates for the benefit of packages. It+-- enables them to find their package information.+module Distribution.Simple.Build.PackageInfoModule+  ( generatePackageInfoModule+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Package+import Distribution.PackageDescription+import Distribution.Simple.Compiler+import Distribution.Simple.LocalBuildInfo+import Distribution.Utils.ShortText+import Distribution.Version++import qualified Distribution.Simple.Build.PackageInfoModule.Z as Z++-- ------------------------------------------------------------++-- * Building Paths_<pkg>.hs++-- ------------------------------------------------------------++generatePackageInfoModule :: PackageDescription -> LocalBuildInfo -> String+generatePackageInfoModule pkg_descr lbi =+  Z.render+    Z.Z+      { Z.zPackageName = showPkgName $ packageName pkg_descr+      , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr+      , Z.zSynopsis = fromShortText $ synopsis pkg_descr+      , Z.zCopyright = fromShortText $ copyright pkg_descr+      , Z.zHomepage = fromShortText $ homepage pkg_descr+      , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax+      }+  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++fixchar :: Char -> Char+fixchar '-' = '_'+fixchar c = c
+ src/Distribution/Simple/Build/PackageInfoModule/Z.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Simple.Build.PackageInfoModule.Z (render, Z (..)) where++import Distribution.ZinzaPrelude++data Z = Z+  { zPackageName :: String+  , zVersionDigits :: String+  , zSynopsis :: String+  , zCopyright :: String+  , zHomepage :: String+  , zSupportsNoRebindableSyntax :: Bool+  }+  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 -Wno-missing-import-lists #-}\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"+  tell "    name,\n"+  tell "    version,\n"+  tell "    synopsis,\n"+  tell "    copyright,\n"+  tell "    homepage,\n"+  tell "  ) where\n"+  tell "\n"+  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)+  tell "\n"
src/Distribution/Simple/Build/PathsModule.hs view
@@ -1,4 +1,5 @@ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Build.Macros -- Copyright   :  Isaac Jones 2003-2005,@@ -13,9 +14,9 @@ -- This is a module that Cabal generates for the benefit of packages. It -- enables them to find their version number and find any installed data files -- at runtime. This code should probably be split off into another module.----module Distribution.Simple.Build.PathsModule (-    generatePathsModule, pkgPathEnvVar+module Distribution.Simple.Build.PathsModule+  ( generatePathsModule+  , pkgPathEnvVar   ) where  import Distribution.Compat.Prelude@@ -25,121 +26,125 @@ import Distribution.PackageDescription import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Utils          (shortRelativePath)+import Distribution.Simple.Utils (shortRelativePath) import Distribution.System import Distribution.Version  import qualified Distribution.Simple.Build.PathsModule.Z as Z  -- ------------------------------------------------------------+ -- * Building Paths_<pkg>.hs+ -- ------------------------------------------------------------  generatePathsModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String-generatePathsModule pkg_descr lbi clbi = Z.render Z.Z-    { Z.zPackageName                = packageName pkg_descr-    , Z.zVersionDigits              = show $ versionNumbers $ packageVersion pkg_descr-    , Z.zSupportsCpp                = supports_cpp-    , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax-    , Z.zAbsolute                   = absolute-    , Z.zRelocatable                = relocatable lbi-    , Z.zIsWindows                  = isWindows-    , Z.zIsI386                     = buildArch == I386-    , Z.zIsX8664                    = buildArch == X86_64-    , Z.zNot                        = not-    , Z.zManglePkgName              = showPkgName--    , Z.zPrefix     = show flat_prefix-    , Z.zBindir     = zBindir-    , Z.zLibdir     = zLibdir-    , Z.zDynlibdir  = zDynlibdir-    , Z.zDatadir    = zDatadir-    , Z.zLibexecdir = zLibexecdir-    , Z.zSysconfdir = zSysconfdir-    }+generatePathsModule pkg_descr lbi clbi =+  Z.render+    Z.Z+      { Z.zPackageName = packageName pkg_descr+      , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr+      , Z.zSupportsCpp = supports_cpp+      , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax+      , Z.zAbsolute = absolute+      , Z.zRelocatable = relocatable lbi+      , Z.zIsWindows = isWindows+      , Z.zIsI386 = buildArch == I386+      , Z.zIsX8664 = buildArch == X86_64+      , Z.zIsAArch64 = buildArch == AArch64+      , Z.zNot = not+      , Z.zManglePkgName = showPkgName+      , Z.zPrefix = show flat_prefix+      , Z.zBindir = zBindir+      , Z.zLibdir = zLibdir+      , Z.zDynlibdir = zDynlibdir+      , Z.zDatadir = zDatadir+      , Z.zLibexecdir = zLibexecdir+      , Z.zSysconfdir = zSysconfdir+      }   where-    supports_cpp                 = supports_language_pragma-    supports_rebindable_syntax   = ghc_newer_than (mkVersion [7,0,1])-    supports_language_pragma     = ghc_newer_than (mkVersion [6,6,1])+    supports_cpp = supports_language_pragma+    supports_rebindable_syntax = ghc_newer_than (mkVersion [7, 0, 1])+    supports_language_pragma = ghc_newer_than (mkVersion [6, 6, 1])      ghc_newer_than minVersion =-        case compilerCompatVersion GHC (compiler lbi) of-            Nothing      -> False-            Just version -> version `withinRange` orLaterVersion minVersion+      case compilerCompatVersion GHC (compiler lbi) of+        Nothing -> False+        Just version -> version `withinRange` orLaterVersion minVersion      -- In several cases we cannot make relocatable installations     absolute =-         hasLibs pkg_descr        -- we can only make progs relocatable-      || isNothing flat_bindirrel -- if the bin dir is an absolute path-      || not (supportsRelocatableProgs (compilerFlavor (compiler lbi)))+      hasLibs pkg_descr -- we can only make progs relocatable+        || isNothing flat_bindirrel -- if the bin dir is an absolute path+        || not (supportsRelocatableProgs (compilerFlavor (compiler lbi)))      -- TODO: Here, and with zIsI386 & zIs8664 we should use TARGET platform     isWindows = case buildOS of-        Windows   -> True-        _         -> False+      Windows -> True+      _ -> False -    supportsRelocatableProgs GHC   = isWindows+    supportsRelocatableProgs GHC = isWindows     supportsRelocatableProgs GHCJS = isWindows-    supportsRelocatableProgs _     = False+    supportsRelocatableProgs _ = False      cid = componentUnitId clbi      InstallDirs-        { bindir     = flat_bindir-        , libdir     = flat_libdir-        , dynlibdir  = flat_dynlibdir-        , datadir    = flat_datadir-        , libexecdir = flat_libexecdir-        , sysconfdir = flat_sysconfdir-        , prefix     = flat_prefix-        } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest+      { bindir = flat_bindir+      , libdir = flat_libdir+      , dynlibdir = flat_dynlibdir+      , datadir = flat_datadir+      , libexecdir = flat_libexecdir+      , sysconfdir = flat_sysconfdir+      , prefix = flat_prefix+      } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest      InstallDirs-        { bindir     = flat_bindirrel-        , libdir     = flat_libdirrel-        , dynlibdir  = flat_dynlibdirrel-        , datadir    = flat_datadirrel-        , libexecdir = flat_libexecdirrel-        , sysconfdir = flat_sysconfdirrel-        } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid+      { bindir = flat_bindirrel+      , libdir = flat_libdirrel+      , dynlibdir = flat_dynlibdirrel+      , datadir = flat_datadirrel+      , libexecdir = flat_libexecdirrel+      , sysconfdir = flat_sysconfdirrel+      } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid      zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir :: String     (zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir)-        | relocatable lbi =-            ( show flat_bindir_reloc-            , show flat_libdir_reloc-            , show flat_dynlibdir_reloc-            , show flat_datadir_reloc-            , show flat_libexecdir_reloc-            , show flat_sysconfdir_reloc-            )-        | absolute        =-            ( show flat_bindir-            , show flat_libdir-            , show flat_dynlibdir-            , show flat_datadir-            , show flat_libexecdir-            , show flat_sysconfdir-            )-        | isWindows       =-            ( "maybe (error \"PathsModule.generate\") id (" ++ show flat_bindirrel ++ ")"-            , mkGetDir flat_libdir flat_libdirrel-            , mkGetDir flat_dynlibdir flat_dynlibdirrel-            , mkGetDir flat_datadir flat_datadirrel-            , mkGetDir flat_libexecdir flat_libexecdirrel-            , mkGetDir flat_sysconfdir flat_sysconfdirrel-            )-        | otherwise       =-            error "panic! generatePathsModule: should never happen"+      | relocatable lbi =+          ( show flat_bindir_reloc+          , show flat_libdir_reloc+          , show flat_dynlibdir_reloc+          , show flat_datadir_reloc+          , show flat_libexecdir_reloc+          , show flat_sysconfdir_reloc+          )+      | absolute =+          ( show flat_bindir+          , show flat_libdir+          , show flat_dynlibdir+          , show flat_datadir+          , show flat_libexecdir+          , show flat_sysconfdir+          )+      | isWindows =+          ( "maybe (error \"PathsModule.generate\") id (" ++ show flat_bindirrel ++ ")"+          , mkGetDir flat_libdir flat_libdirrel+          , mkGetDir flat_dynlibdir flat_dynlibdirrel+          , mkGetDir flat_datadir flat_datadirrel+          , mkGetDir flat_libexecdir flat_libexecdirrel+          , mkGetDir flat_sysconfdir flat_sysconfdirrel+          )+      | otherwise =+          error "panic! generatePathsModule: should never happen"      mkGetDir :: FilePath -> Maybe FilePath -> String-    mkGetDir _   (Just dirrel) = "getPrefixDirRel " ++ show dirrel-    mkGetDir dir Nothing       = "return " ++ show dir+    mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel+    mkGetDir dir Nothing = "return " ++ show dir -    flat_bindir_reloc     = shortRelativePath flat_prefix flat_bindir-    flat_libdir_reloc     = shortRelativePath flat_prefix flat_libdir-    flat_dynlibdir_reloc  = shortRelativePath flat_prefix flat_dynlibdir-    flat_datadir_reloc    = shortRelativePath flat_prefix flat_datadir+    flat_bindir_reloc = shortRelativePath flat_prefix flat_bindir+    flat_libdir_reloc = shortRelativePath flat_prefix flat_libdir+    flat_dynlibdir_reloc = shortRelativePath flat_prefix flat_dynlibdir+    flat_datadir_reloc = shortRelativePath flat_prefix flat_datadir     flat_libexecdir_reloc = shortRelativePath flat_prefix flat_libexecdir     flat_sysconfdir_reloc = shortRelativePath flat_prefix flat_sysconfdir @@ -149,15 +154,17 @@ -- Note: The format of these strings is part of Cabal's public API; -- changing this function constitutes a *backwards-compatibility* break. pkgPathEnvVar-    :: PackageDescription-    -> String     -- ^ path component; one of \"bindir\", \"libdir\", -- \"datadir\", \"libexecdir\", or \"sysconfdir\"-    -> String     -- ^ environment variable name+  :: PackageDescription+  -> String+  -- ^ path component; one of \"bindir\", \"libdir\", -- \"datadir\", \"libexecdir\", or \"sysconfdir\"+  -> String+  -- ^ environment variable name pkgPathEnvVar pkg_descr var =-    showPkgName (packageName pkg_descr) ++ "_" ++ var+  showPkgName (packageName pkg_descr) ++ "_" ++ var  showPkgName :: PackageName -> String showPkgName = map fixchar . unPackageName  fixchar :: Char -> Char fixchar '-' = '_'-fixchar c   = c+fixchar c = c
src/Distribution/Simple/Build/PathsModule/Z.hs view
@@ -1,3 +1,4 @@+{- FOURMOLU_DISABLE -} {-# LANGUAGE DeriveGeneric #-} module Distribution.Simple.Build.PathsModule.Z (render, Z(..)) where import Distribution.ZinzaPrelude@@ -11,6 +12,7 @@          zIsWindows :: Bool,          zIsI386 :: Bool,          zIsX8664 :: Bool,+         zIsAArch64 :: Bool,          zPrefix :: FilePath,          zBindir :: FilePath,          zLibdir :: FilePath,@@ -41,8 +43,35 @@     return ()   else do     return ()-  tell "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n"+  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 -Wno-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"@@ -60,7 +89,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"@@ -92,19 +120,88 @@     tell "catchIO = Exception.catch\n"     return ()   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"+      tell "minusFileName dir \"\"     = dir\n"+      tell "minusFileName dir \".\"    = dir\n"+      tell "minusFileName dir suffix =\n"+      tell "  minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"+      tell "\n"+      tell "splitFileName :: FilePath -> (String, String)\n"+      tell "splitFileName p = (reverse (path2++drive), reverse fname)\n"+      tell "  where\n"+      tell "    (path,drive) = case p of\n"+      tell "      (c:':':p') -> (reverse p',[':',c])\n"+      tell "      _          -> (reverse p ,\"\")\n"+      tell "    (fname,path1) = break isPathSeparator path\n"+      tell "    path2 = case path1 of\n"+      tell "      []                           -> \".\"\n"+      tell "      [_]                          -> path1   -- don't remove the trailing slash if\n"+      tell "                                              -- there is only one character\n"+      tell "      (c:path') | isPathSeparator c -> path'\n"+      tell "      _                             -> path1\n"+      return ()+  tell "\n"+  tell "\n"   if (zRelocatable z_root)   then do     tell "\n"@@ -147,6 +244,8 @@     tell (zSysconfdir z_root)     tell ")\n"     tell "\n"+    z_var0_function_defs+    tell "\n"     return ()   else do     if (zAbsolute z_root)@@ -237,6 +336,8 @@         tell ") `joinFileName` dirRel)\n"         tell "            | otherwise  -> try_size (size * 2)\n"         tell "\n"+        z_var0_function_defs+        tell "\n"         if (zIsI386 z_root)         then do           tell "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n"@@ -249,9 +350,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"@@ -266,38 +374,18 @@     return ()   tell "\n"   tell "\n"-  if (zNot z_root (zAbsolute z_root))-  then do-    tell "minusFileName :: FilePath -> String -> FilePath\n"-    tell "minusFileName dir \"\"     = dir\n"-    tell "minusFileName dir \".\"    = dir\n"-    tell "minusFileName dir suffix =\n"-    tell "  minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"-    tell "\n"-    tell "splitFileName :: FilePath -> (String, String)\n"-    tell "splitFileName p = (reverse (path2++drive), reverse fname)\n"-    tell "  where\n"-    tell "    (path,drive) = case p of\n"-    tell "       (c:':':p') -> (reverse p',[':',c])\n"-    tell "       _          -> (reverse p ,\"\")\n"-    tell "    (fname,path1) = break isPathSeparator path\n"-    tell "    path2 = case path1 of\n"-    tell "      []                           -> \".\"\n"-    tell "      [_]                          -> path1   -- don't remove the trailing slash if\n"-    tell "                                              -- there is only one character\n"-    tell "      (c:path') | isPathSeparator c -> path'\n"-    tell "      _                             -> path1\n"-    return ()-  else do-    return ()-  tell "\n"   tell "joinFileName :: String -> String -> FilePath\n"   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,9 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}+ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.BuildPaths -- Copyright   :  Isaac Jones 2003-2004,@@ -11,52 +14,71 @@ -- Portability :  portable -- -- A bunch of dirs, paths and file names used for intermediate build steps.-----module Distribution.Simple.BuildPaths (-    defaultDistPref, srcPref,-    haddockDirName, hscolourPref, haddockPref,-    autogenPackageModulesDir,-    autogenComponentModulesDir,--    autogenPathsModuleName,-    cppHeaderName,-    haddockName,--    mkGenericStaticLibName,-    mkLibName,-    mkProfLibName,-    mkGenericSharedLibName,-    mkSharedLibName,-    mkStaticLibName,-    mkGenericSharedBundledLibName,+module Distribution.Simple.BuildPaths+  ( defaultDistPref+  , srcPref+  , buildInfoPref+  , haddockDirName+  , haddockLibraryDirPath+  , haddockTestDirPath+  , haddockBenchmarkDirPath+  , hscolourPref+  , haddockPref+  , autogenPackageModulesDir+  , autogenComponentModulesDir+  , autogenPathsModuleName+  , autogenPackageInfoModuleName+  , cppHeaderName+  , haddockPath+  , haddockPackageLibraryName+  , haddockPackageLibraryName'+  , haddockLibraryName+  , haddockLibraryPath+  , mkGenericStaticLibName+  , mkLibName+  , mkProfLibName+  , mkGenericSharedLibName+  , mkSharedLibName+  , mkProfSharedLibName+  , mkStaticLibName+  , mkGenericSharedBundledLibName+  , exeExtension+  , objExtension+  , dllExtension+  , staticLibExtension -    exeExtension,-    objExtension,-    dllExtension,-    staticLibExtension,     -- * Source files & build directories-    getSourceFiles, getLibSourceFiles, getExeSourceFiles,-    getFLibSourceFiles, exeBuildDir, flibBuildDir,+  , getSourceFiles+  , getLibSourceFiles+  , getExeSourceFiles+  , getTestSourceFiles+  , getBenchmarkSourceFiles+  , getFLibSourceFiles+  , exeBuildDir+  , flibBuildDir+  , stubName+  , testBuildDir+  , benchmarkBuildDir   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Package-import Distribution.ModuleName as ModuleName+import Data.List (stripPrefix) import Distribution.Compiler+import Distribution.ModuleName as ModuleName+import Distribution.Package import Distribution.PackageDescription-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Setup import Distribution.Pretty-import Distribution.System-import Distribution.Verbosity+import Distribution.Simple.Errors+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PreProcess.Types (builtinHaskellSuffixes)+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Haddock (HaddockTarget (..)) import Distribution.Simple.Utils+import Distribution.System import Distribution.Utils.Path--import Data.List (stripPrefix)-import System.FilePath ((</>), (<.>), normalise)+import Distribution.Verbosity  -- --------------------------------------------------------------------------- -- Build directories and files@@ -64,29 +86,78 @@ srcPref :: FilePath -> FilePath srcPref distPref = distPref </> "src" -hscolourPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath+hscolourPref+  :: HaddockTarget+  -> SymbolicPath root (Dir Dist)+  -> PackageDescription+  -> SymbolicPath root (Dir Artifacts) hscolourPref = haddockPref +-- | Build info json file, generated in every build+buildInfoPref+  :: SymbolicPath root (Dir Dist)+  -> SymbolicPath root File+buildInfoPref distPref = distPref </> makeRelativePathEx "build-info.json"+ -- | This is the name of the directory in which the generated haddocks -- should be stored. It does not include the @<dist>/doc/html@ prefix.+--+-- It is also used by `haddock-project` when constructing its output directory. haddockDirName :: HaddockTarget -> PackageDescription -> FilePath haddockDirName ForDevelopment = prettyShow . packageName haddockDirName ForHackage = (++ "-docs") . prettyShow . packageId +-- | This is the name of the directory in which the generated haddocks for+-- a (sub)library should be stored. It does not include the @<dist>/doc/html@+-- prefix.+--+-- It is also used by `haddock-project` when constructing its output directory.+haddockLibraryDirPath+  :: HaddockTarget+  -> PackageDescription+  -> Library+  -> FilePath+haddockLibraryDirPath haddockTarget pkg_descr lib =+  case libName lib of+    LSubLibName sublib_name ->+      haddockDirName haddockTarget pkg_descr </> prettyShow sublib_name+    _ -> haddockDirName haddockTarget pkg_descr++haddockTestDirPath+  :: HaddockTarget+  -> PackageDescription+  -> TestSuite+  -> FilePath+haddockTestDirPath haddockTarget pkg_descr test =+  haddockDirName haddockTarget pkg_descr </> prettyShow (testName test)++haddockBenchmarkDirPath+  :: HaddockTarget+  -> PackageDescription+  -> Benchmark+  -> FilePath+haddockBenchmarkDirPath haddockTarget pkg_descr bench =+  haddockDirName haddockTarget pkg_descr </> prettyShow (benchmarkName bench)+ -- | The directory to which generated haddock documentation should be written.-haddockPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath-haddockPref haddockTarget distPref pkg_descr-    = distPref </> "doc" </> "html" </> haddockDirName haddockTarget pkg_descr+haddockPref+  :: HaddockTarget+  -> SymbolicPath root (Dir Dist)+  -> PackageDescription+  -> SymbolicPath root (Dir Artifacts)+haddockPref haddockTarget distPref pkg_descr =+  distPref </> makeRelativePathEx ("doc" </> "html" </> haddockDirName haddockTarget pkg_descr)  -- | The directory in which we put auto-generated modules for EVERY -- component in the package.-autogenPackageModulesDir :: LocalBuildInfo -> String-autogenPackageModulesDir lbi = buildDir lbi </> "global-autogen"+autogenPackageModulesDir :: LocalBuildInfo -> SymbolicPath Pkg (Dir Source)+autogenPackageModulesDir lbi = buildDir lbi </> makeRelativePathEx "global-autogen"  -- | The directory in which we put auto-generated modules for a -- particular component.-autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> String-autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi </> "autogen"+autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Source)+autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi </> makeRelativePathEx "autogen"+ -- NB: Look at 'checkForeignDeps' for where a simplified version of this -- has been copy-pasted. @@ -98,78 +169,203 @@ autogenPathsModuleName pkg_descr =   ModuleName.fromString $     "Paths_" ++ map fixchar (prettyShow (packageName pkg_descr))-  where fixchar '-' = '_'-        fixchar c   = c+  where+    fixchar '-' = '_'+    fixchar c = c -haddockName :: PackageDescription -> FilePath-haddockName pkg_descr = prettyShow (packageName pkg_descr) <.> "haddock"+-- | The name of the auto-generated PackageInfo_* module associated with a package+autogenPackageInfoModuleName :: PackageDescription -> ModuleName+autogenPackageInfoModuleName pkg_descr =+  ModuleName.fromString $+    "PackageInfo_" ++ map fixchar (prettyShow (packageName pkg_descr))+  where+    fixchar '-' = '_'+    fixchar c = c +haddockPath :: PackageDescription -> FilePath+haddockPath pkg_descr = prettyShow (packageName pkg_descr) <.> "haddock"++-- | A name of a (sub)library used by haddock, in the form+-- `<package>:<library>` if it is a sublibrary, or `<package>` if it is the+-- main library.+--+-- Used by `haddock-project` and `Distribution.Simple.Haddock`.+haddockPackageLibraryName :: PackageDescription -> Library -> String+haddockPackageLibraryName pkg_descr lib =+  haddockPackageLibraryName' (packageName pkg_descr) (libName lib)++haddockPackageLibraryName' :: PackageName -> LibraryName -> String+haddockPackageLibraryName' pkg_name lib_name =+  case lib_name of+    LSubLibName sublib_name ->+      prettyShow pkg_name ++ ":" ++ prettyShow sublib_name+    LMainLibName -> prettyShow pkg_name++-- | A name of a (sub)library used by haddock.+haddockLibraryName :: PackageDescription -> Library -> String+haddockLibraryName pkg_descr lib =+  case libName lib of+    LSubLibName sublib_name -> prettyShow sublib_name+    LMainLibName -> prettyShow (packageName pkg_descr)++-- | File path of the ".haddock" file.+haddockLibraryPath :: PackageDescription -> Library -> FilePath+haddockLibraryPath pkg_descr lib = haddockLibraryName pkg_descr lib <.> "haddock"+ -- ----------------------------------------------------------------------------- -- Source File helper -getLibSourceFiles :: Verbosity-                     -> LocalBuildInfo-                     -> Library-                     -> ComponentLocalBuildInfo-                     -> IO [(ModuleName.ModuleName, FilePath)]-getLibSourceFiles verbosity lbi lib clbi = getSourceFiles verbosity searchpaths modules+getLibSourceFiles+  :: Verbosity+  -> LocalBuildInfo+  -> Library+  -> ComponentLocalBuildInfo+  -> IO [(ModuleName.ModuleName, SymbolicPath Pkg File)]+getLibSourceFiles verbosity lbi lib clbi =+  getSourceFiles verbosity mbWorkDir searchpaths modules   where-    bi               = libBuildInfo lib-    modules          = allLibModules lib clbi-    searchpaths      = componentBuildDir lbi clbi : map getSymbolicPath (hsSourceDirs bi) ++-                     [ autogenComponentModulesDir lbi clbi-                     , autogenPackageModulesDir lbi ]+    bi = libBuildInfo lib+    modules = allLibModules lib clbi+    mbWorkDir = mbWorkDirLBI lbi+    searchpaths =+      coerceSymbolicPath (componentBuildDir lbi clbi)+        : hsSourceDirs bi+        ++ [ autogenComponentModulesDir lbi clbi+           , autogenPackageModulesDir lbi+           ] -getExeSourceFiles :: Verbosity-                     -> LocalBuildInfo-                     -> Executable-                     -> ComponentLocalBuildInfo-                     -> IO [(ModuleName.ModuleName, FilePath)]+getExeSourceFiles+  :: Verbosity+  -> LocalBuildInfo+  -> Executable+  -> ComponentLocalBuildInfo+  -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)] getExeSourceFiles verbosity lbi exe clbi = do-    moduleFiles <- getSourceFiles verbosity searchpaths modules-    srcMainPath <- findFileEx verbosity (map getSymbolicPath $ hsSourceDirs bi) (modulePath exe)-    return ((ModuleName.main, srcMainPath) : moduleFiles)+  moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules+  srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) (modulePath exe)+  return ((ModuleName.main, srcMainPath) : moduleFiles)   where-    bi          = buildInfo exe-    modules     = otherModules bi-    searchpaths = autogenComponentModulesDir lbi clbi-                : autogenPackageModulesDir lbi-                : exeBuildDir lbi exe : map getSymbolicPath (hsSourceDirs bi)+    mbWorkDir = mbWorkDirLBI lbi+    bi = buildInfo exe+    modules = otherModules bi+    searchpaths =+      autogenComponentModulesDir lbi clbi+        : autogenPackageModulesDir lbi+        : coerceSymbolicPath (exeBuildDir lbi exe)+        : hsSourceDirs bi -getFLibSourceFiles :: Verbosity-                   -> LocalBuildInfo-                   -> ForeignLib-                   -> ComponentLocalBuildInfo-                   -> IO [(ModuleName.ModuleName, FilePath)]-getFLibSourceFiles verbosity lbi flib clbi = getSourceFiles verbosity searchpaths modules+getTestSourceFiles+  :: Verbosity+  -> LocalBuildInfo+  -> TestSuite+  -> ComponentLocalBuildInfo+  -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)]+getTestSourceFiles verbosity lbi test@TestSuite{testInterface = TestSuiteExeV10 _ path} clbi = do+  moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules+  srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) path+  return ((ModuleName.main, srcMainPath) : moduleFiles)   where-    bi          = foreignLibBuildInfo flib-    modules     = otherModules bi-    searchpaths = autogenComponentModulesDir lbi clbi-                : autogenPackageModulesDir lbi-                : flibBuildDir lbi flib : map getSymbolicPath (hsSourceDirs bi)+    mbWorkDir = mbWorkDirLBI lbi+    bi = testBuildInfo test+    modules = otherModules bi+    searchpaths =+      autogenComponentModulesDir lbi clbi+        : autogenPackageModulesDir lbi+        : coerceSymbolicPath (testBuildDir lbi test)+        : hsSourceDirs bi+getTestSourceFiles _ _ _ _ = return [] -getSourceFiles :: Verbosity -> [FilePath]-                  -> [ModuleName.ModuleName]-                  -> IO [(ModuleName.ModuleName, FilePath)]-getSourceFiles verbosity dirs modules = flip traverse modules $ \m -> fmap ((,) m) $-    findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m)-      >>= maybe (notFound m) (return . normalise)+getBenchmarkSourceFiles+  :: Verbosity+  -> LocalBuildInfo+  -> Benchmark+  -> ComponentLocalBuildInfo+  -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)]+getBenchmarkSourceFiles verbosity lbi bench@Benchmark{benchmarkInterface = BenchmarkExeV10 _ path} clbi = do+  moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules+  srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) path+  return ((ModuleName.main, srcMainPath) : moduleFiles)   where-    notFound module_ = die' verbosity $ "can't find source for module " ++ prettyShow module_+    mbWorkDir = mbWorkDirLBI lbi+    bi = benchmarkBuildInfo bench+    modules = otherModules bi+    searchpaths =+      autogenComponentModulesDir lbi clbi+        : autogenPackageModulesDir lbi+        : coerceSymbolicPath (benchmarkBuildDir lbi bench)+        : hsSourceDirs bi+getBenchmarkSourceFiles _ _ _ _ = return [] +getFLibSourceFiles+  :: Verbosity+  -> LocalBuildInfo+  -> ForeignLib+  -> ComponentLocalBuildInfo+  -> IO [(ModuleName.ModuleName, SymbolicPath Pkg File)]+getFLibSourceFiles verbosity lbi flib clbi =+  getSourceFiles verbosity mbWorkDir searchpaths modules+  where+    bi = foreignLibBuildInfo flib+    modules = otherModules bi+    mbWorkDir = mbWorkDirLBI lbi+    searchpaths =+      autogenComponentModulesDir lbi clbi+        : autogenPackageModulesDir lbi+        : coerceSymbolicPath (flibBuildDir lbi flib)+        : hsSourceDirs bi++getSourceFiles+  :: Verbosity+  -> Maybe (SymbolicPath CWD ('Dir Pkg))+  -> [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) $+    findFileCwdWithExtension+      mbWorkDir+      builtinHaskellSuffixes+      dirs+      (moduleNameSymbolicPath m)+      >>= maybe (notFound m) (return . normaliseSymbolicPath)+  where+    notFound module_ =+      dieWithException verbosity $ CantFindSourceModule module_+ -- | The directory where we put build results for an executable-exeBuildDir :: LocalBuildInfo -> Executable -> FilePath-exeBuildDir lbi exe = buildDir lbi </> nm </> nm ++ "-tmp"+exeBuildDir :: LocalBuildInfo -> Executable -> SymbolicPath Pkg (Dir Build)+exeBuildDir lbi exe = buildDir lbi </> makeRelativePathEx (nm </> nm ++ "-tmp")   where     nm = unUnqualComponentName $ exeName exe  -- | The directory where we put build results for a foreign library-flibBuildDir :: LocalBuildInfo -> ForeignLib -> FilePath-flibBuildDir lbi flib = buildDir lbi </> nm </> nm ++ "-tmp"+flibBuildDir :: LocalBuildInfo -> ForeignLib -> SymbolicPath Pkg (Dir Build)+flibBuildDir lbi flib = buildDir lbi </> makeRelativePathEx (nm </> nm ++ "-tmp")   where     nm = unUnqualComponentName $ foreignLibName flib +-- | The name of the stub executable associated with a library 'TestSuite'.+stubName :: TestSuite -> FilePath+stubName t = unUnqualComponentName (testName t) ++ "Stub"++-- | The directory where we put build results for a test suite+testBuildDir :: LocalBuildInfo -> TestSuite -> SymbolicPath Pkg (Dir Build)+testBuildDir lbi tst =+  buildDir lbi </> makeRelativePathEx testDir+  where+    testDir = case testInterface tst of+      TestSuiteLibV09{} ->+        stubName tst </> stubName tst ++ "-tmp"+      _ -> nm </> nm ++ "-tmp"+    nm = unUnqualComponentName $ testName tst++-- | The directory where we put build results for a benchmark suite+benchmarkBuildDir :: LocalBuildInfo -> Benchmark -> SymbolicPath Pkg (Dir Build)+benchmarkBuildDir lbi bm =+  buildDir lbi </> makeRelativePathEx (nm </> nm ++ "-tmp")+  where+    nm = unUnqualComponentName $ benchmarkName bm+ -- --------------------------------------------------------------------------- -- Library file names @@ -182,29 +378,35 @@ mkLibName lib = mkGenericStaticLibName (getHSLibraryName lib)  mkProfLibName :: UnitId -> String-mkProfLibName lib =  mkGenericStaticLibName (getHSLibraryName lib ++ "_p")+mkProfLibName lib = mkGenericStaticLibName (getHSLibraryName lib ++ "_p")  -- | Create a library name for a shared library from a given name. -- Prepends @lib@ and appends the @-\<compilerFlavour\>\<compilerVersion\>@ -- as well as the shared library extension. mkGenericSharedLibName :: Platform -> CompilerId -> String -> String-mkGenericSharedLibName platform (CompilerId compilerFlavor compilerVersion) lib-  = mconcat [ "lib", lib, "-", comp <.> dllExtension platform ]-  where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion+mkGenericSharedLibName platform (CompilerId compilerFlavor compilerVersion) lib =+  mconcat ["lib", lib, "-", comp <.> dllExtension platform]+  where+    comp = prettyShow compilerFlavor ++ prettyShow compilerVersion  -- Implement proper name mangling for dynamical shared objects -- @libHS\<packagename\>-\<compilerFlavour\>\<compilerVersion\>@ -- e.g. @libHSbase-2.1-ghc6.6.1.so@ mkSharedLibName :: Platform -> CompilerId -> UnitId -> String-mkSharedLibName platform comp lib-  = mkGenericSharedLibName platform comp (getHSLibraryName lib)+mkSharedLibName platform comp lib =+  mkGenericSharedLibName platform comp (getHSLibraryName lib) +mkProfSharedLibName :: Platform -> CompilerId -> UnitId -> String+mkProfSharedLibName platform comp lib =+  mkGenericSharedLibName platform comp (getHSLibraryName lib ++ "_p")+ -- Static libs are named the same as shared libraries, only with -- a different extension. mkStaticLibName :: Platform -> CompilerId -> UnitId -> String-mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib-  = "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform-  where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion+mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib =+  "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform+  where+    comp = prettyShow compilerFlavor ++ prettyShow compilerVersion  -- | Create a library name for a bundled shared library from a given name. -- This matches the naming convention for shared libraries as implemented in@@ -217,23 +419,26 @@ --     "Cffi" -> "libffi.so" mkGenericSharedBundledLibName :: Platform -> CompilerId -> String -> String mkGenericSharedBundledLibName platform comp lib-  | "HS" `isPrefixOf` lib-    = mkGenericSharedLibName platform comp lib-  | Just lib' <- stripPrefix "C" lib-    = "lib" ++ lib' <.> dllExtension platform-  | otherwise-    = error ("Don't understand library name " ++ lib)+  | "HS" `isPrefixOf` lib =+      mkGenericSharedLibName platform comp lib+  | Just lib' <- stripPrefix "C" lib =+      "lib" ++ lib' <.> dllExtension platform+  | otherwise =+      error ("Don't understand library name " ++ lib)  -- ------------------------------------------------------------+ -- * Platform file extensions+ -- ------------------------------------------------------------  -- | Default extension for executable files on the current platform. -- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) exeExtension :: Platform -> String-exeExtension (Platform _arch os) = case os of-                   Windows -> "exe"-                   _       -> ""+exeExtension platform = case platform of+  Platform _ Windows -> "exe"+  Platform Wasm32 _ -> "wasm"+  _ -> ""  -- | Extension for object files. For GHC the extension is @\"o\"@. objExtension :: String@@ -242,10 +447,10 @@ -- | Extension for dynamically linked (or shared) libraries -- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows) dllExtension :: Platform -> String-dllExtension (Platform _arch os)= case os of-                   Windows -> "dll"-                   OSX     -> "dylib"-                   _       -> "so"+dllExtension (Platform _arch os) = case os of+  Windows -> "dll"+  OSX -> "dylib"+  _ -> "so"  -- | Extension for static libraries --@@ -253,5 +458,5 @@ -- interested in, not the build OS. staticLibExtension :: Platform -> String staticLibExtension (Platform _arch os) = case os of-                       Windows -> "lib"-                       _       -> "a"+  Windows -> "lib"+  _ -> "a"
src/Distribution/Simple/BuildTarget.hs view
@@ -1,1064 +1,1110 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.BuildTargets--- Copyright   :  (c) Duncan Coutts 2012--- License     :  BSD-like------ Maintainer  :  duncan@community.haskell.org------ Handling for user-specified build targets-------------------------------------------------------------------------------module Distribution.Simple.BuildTarget (-    -- * Main interface-    readTargetInfos,-    readBuildTargets, -- in case you don't have LocalBuildInfo--    -- * Build targets-    BuildTarget(..),-    showBuildTarget,-    QualLevel(..),-    buildTargetComponentName,--    -- * Parsing user build targets-    UserBuildTarget,-    readUserBuildTargets,-    showUserBuildTarget,-    UserBuildTargetProblem(..),-    reportUserBuildTargetProblems,--    -- * Resolving build targets-    resolveBuildTargets,-    BuildTargetProblem(..),-    reportBuildTargetProblems,-  ) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Types.TargetInfo-import Distribution.Types.LocalBuildInfo-import Distribution.Types.ComponentRequestedSpec-import Distribution.Types.ForeignLib-import Distribution.Types.UnqualComponentName--import Distribution.Package-import Distribution.PackageDescription-import Distribution.ModuleName-import Distribution.Simple.LocalBuildInfo-import Distribution.Pretty-import Distribution.Parsec-import Distribution.Simple.Utils-import Distribution.Verbosity-import Distribution.Utils.Path--import qualified Distribution.Compat.CharParsing as P--import Control.Monad ( msum )-import Data.List ( stripPrefix, groupBy )-import qualified Data.List.NonEmpty as NE-import System.FilePath as FilePath-         ( dropExtension, normalise, splitDirectories, joinPath, splitPath-         , hasTrailingPathSeparator )-import System.Directory ( doesFileExist, doesDirectoryExist )-import qualified Data.Map as Map---- | Take a list of 'String' build targets, and parse and validate them--- into actual 'TargetInfo's to be built/registered/whatever.-readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo]-readTargetInfos verbosity pkg_descr lbi args = do-    build_targets <- readBuildTargets verbosity pkg_descr args-    checkBuildTargets verbosity pkg_descr lbi build_targets---- --------------------------------------------------------------- * User build targets--- ---------------------------------------------------------------- | Various ways that a user may specify a build target.----data UserBuildTarget =--     -- | A target specified by a single name. This could be a component-     -- module or file.-     ---     -- > cabal build foo-     -- > cabal build Data.Foo-     -- > cabal build Data/Foo.hs  Data/Foo.hsc-     ---     UserBuildTargetSingle String--     -- | A target specified by a qualifier and name. This could be a component-     -- name qualified by the component namespace kind, or a module or file-     -- qualified by the component name.-     ---     -- > cabal build lib:foo exe:foo-     -- > cabal build foo:Data.Foo-     -- > cabal build foo:Data/Foo.hs-     ---   | UserBuildTargetDouble String String--     -- | A fully qualified target, either a module or file qualified by a-     -- component name with the component namespace kind.-     ---     -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs-     -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo-     ---   | UserBuildTargetTriple String String String-  deriving (Show, Eq, Ord)----- --------------------------------------------------------------- * Resolved build targets--- ---------------------------------------------------------------- | A fully resolved build target.----data BuildTarget =--     -- | A specific component-     ---     BuildTargetComponent ComponentName--     -- | A specific module within a specific component.-     ---   | BuildTargetModule ComponentName ModuleName--     -- | A specific file within a specific component.-     ---   | BuildTargetFile ComponentName FilePath-  deriving (Eq, Show, Generic)--instance Binary BuildTarget--buildTargetComponentName :: BuildTarget -> ComponentName-buildTargetComponentName (BuildTargetComponent cn)   = cn-buildTargetComponentName (BuildTargetModule    cn _) = cn-buildTargetComponentName (BuildTargetFile      cn _) = cn---- | Read a list of user-supplied build target strings and resolve them to--- 'BuildTarget's according to a 'PackageDescription'. If there are problems--- with any of the targets e.g. they don't exist or are misformatted, throw an--- 'IOException'.-readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget]-readBuildTargets verbosity pkg targetStrs = do-    let (uproblems, utargets) = readUserBuildTargets targetStrs-    reportUserBuildTargetProblems verbosity uproblems--    utargets' <- traverse checkTargetExistsAsFile utargets--    let (bproblems, btargets) = resolveBuildTargets pkg utargets'-    reportBuildTargetProblems verbosity bproblems--    return btargets--checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)-checkTargetExistsAsFile t = do-    fexists <- existsAsFile (fileComponentOfTarget t)-    return (t, fexists)--  where-    existsAsFile f = do-      exists <- doesFileExist f-      case splitPath f of-        (d:_)   | hasTrailingPathSeparator d -> doesDirectoryExist d-        (d:_:_) | not exists                 -> doesDirectoryExist d-        _                                    -> return exists--    fileComponentOfTarget (UserBuildTargetSingle     s1) = s1-    fileComponentOfTarget (UserBuildTargetDouble _   s2) = s2-    fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3----- --------------------------------------------------------------- * Parsing user targets--- --------------------------------------------------------------readUserBuildTargets :: [String] -> ([UserBuildTargetProblem]-                                    ,[UserBuildTarget])-readUserBuildTargets = partitionEithers . map readUserBuildTarget---- |------ >>> readUserBuildTarget "comp"--- Right (UserBuildTargetSingle "comp")------ >>> readUserBuildTarget "lib:comp"--- Right (UserBuildTargetDouble "lib" "comp")------ >>> readUserBuildTarget "pkg:lib:comp"--- Right (UserBuildTargetTriple "pkg" "lib" "comp")------ >>> readUserBuildTarget "\"comp\""--- Right (UserBuildTargetSingle "comp")------ >>> readUserBuildTarget "lib:\"comp\""--- Right (UserBuildTargetDouble "lib" "comp")------ >>> readUserBuildTarget "pkg:lib:\"comp\""--- Right (UserBuildTargetTriple "pkg" "lib" "comp")------ >>> readUserBuildTarget "pkg:lib:comp:more"--- Left (UserBuildTargetUnrecognised "pkg:lib:comp:more")------ >>> readUserBuildTarget "pkg:\"lib\":comp"--- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp")----readUserBuildTarget :: String -> Either UserBuildTargetProblem-                                        UserBuildTarget-readUserBuildTarget targetstr =-    case explicitEitherParsec parseTargetApprox targetstr of-      Left _    -> Left  (UserBuildTargetUnrecognised targetstr)-      Right tgt -> Right tgt--  where-    parseTargetApprox :: CabalParsing m => m UserBuildTarget-    parseTargetApprox = do-        -- read one, two, or three tokens, where last could be "hs-string"-        ts <- tokens-        return $ case ts of-            (a, Nothing)           -> UserBuildTargetSingle a-            (a, Just (b, Nothing)) -> UserBuildTargetDouble a b-            (a, Just (b, Just c))  -> UserBuildTargetTriple a b c--    tokens :: CabalParsing m => m (String, Maybe (String, Maybe String))-    tokens = (\s -> (s, Nothing)) <$> parsecHaskellString-        <|> (,) <$> token <*> P.optional (P.char ':' *> tokens2)--    tokens2 :: CabalParsing m => m (String, Maybe String)-    tokens2 = (\s -> (s, Nothing)) <$> parsecHaskellString-        <|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token))--    token :: CabalParsing m => m String-    token  = P.munch1 (\x -> not (isSpace x) && x /= ':')--data UserBuildTargetProblem-   = UserBuildTargetUnrecognised String-  deriving Show--reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO ()-reportUserBuildTargetProblems verbosity problems = do-    case [ target | UserBuildTargetUnrecognised target <- problems ] of-      []     -> return ()-      target ->-        die' verbosity $ unlines-                [ "Unrecognised build target '" ++ name ++ "'."-                | name <- target ]-           ++ "Examples:\n"-           ++ " - build foo          -- component name "-           ++ "(library, executable, test-suite or benchmark)\n"-           ++ " - build Data.Foo     -- module name\n"-           ++ " - build Data/Foo.hsc -- file name\n"-           ++ " - build lib:foo exe:foo   -- component qualified by kind\n"-           ++ " - build foo:Data.Foo      -- module qualified by component\n"-           ++ " - build foo:Data/Foo.hsc  -- file qualified by component"--showUserBuildTarget :: UserBuildTarget -> String-showUserBuildTarget = intercalate ":" . getComponents-  where-    getComponents (UserBuildTargetSingle s1)       = [s1]-    getComponents (UserBuildTargetDouble s1 s2)    = [s1,s2]-    getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3]---- | Unless you use 'QL1', this function is PARTIAL;--- use 'showBuildTarget' instead.-showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String-showBuildTarget' ql pkgid bt =-    showUserBuildTarget (renderBuildTarget ql bt pkgid)---- | Unambiguously render a 'BuildTarget', so that it can--- be parsed in all situations.-showBuildTarget :: PackageId -> BuildTarget -> String-showBuildTarget pkgid t =-    showBuildTarget' (qlBuildTarget t) pkgid t-  where-    qlBuildTarget BuildTargetComponent{} = QL2-    qlBuildTarget _                      = QL3----- --------------------------------------------------------------- * Resolving user targets to build targets--- --------------------------------------------------------------{--stargets =-  [ BuildTargetComponent (CExeName "foo")-  , BuildTargetModule    (CExeName "foo") (mkMn "Foo")-  , BuildTargetModule    (CExeName "tst") (mkMn "Foo")-  ]-    where-    mkMn :: String -> ModuleName-    mkMn  = fromJust . simpleParse--ex_pkgid :: PackageIdentifier-Just ex_pkgid = simpleParse "thelib"--}---- | Given a bunch of user-specified targets, try to resolve what it is they--- refer to.----resolveBuildTargets :: PackageDescription-                    -> [(UserBuildTarget, Bool)]-                    -> ([BuildTargetProblem], [BuildTarget])-resolveBuildTargets pkg = partitionEithers-                        . map (uncurry (resolveBuildTarget pkg))--resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool-                   -> Either BuildTargetProblem BuildTarget-resolveBuildTarget pkg userTarget fexists =-    case findMatch (matchBuildTarget pkg userTarget fexists) of-      Unambiguous target  -> Right target-      Ambiguous   targets -> Left (BuildTargetAmbiguous userTarget targets')-                               where targets' = disambiguateBuildTargets-                                                    (packageId pkg)-                                                    userTarget-                                                    targets-      None        errs    -> Left (classifyMatchErrors errs)--  where-    classifyMatchErrors errs-      | Just expected' <- NE.nonEmpty expected-                            = let (things, got:|_) = NE.unzip expected' in-                              BuildTargetExpected userTarget (NE.toList things) got-      | not (null nosuch)   = BuildTargetNoSuch   userTarget nosuch-      | otherwise = error $ "resolveBuildTarget: internal error in matching"-      where-        expected = [ (thing, got) | MatchErrorExpected thing got <- errs ]-        nosuch   = [ (thing, got) | MatchErrorNoSuch   thing got <- errs ]---data BuildTargetProblem-   = BuildTargetExpected  UserBuildTarget [String]  String-     -- ^  [expected thing] (actually got)-   | BuildTargetNoSuch    UserBuildTarget [(String, String)]-     -- ^ [(no such thing,  actually got)]-   | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)]-  deriving Show---disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget]-                         -> [(UserBuildTarget, BuildTarget)]-disambiguateBuildTargets pkgid original =-    disambiguate (userTargetQualLevel original)-  where-    disambiguate ql ts-        | null amb  = unamb-        | otherwise = unamb ++ disambiguate (succ ql) amb-      where-        (amb, unamb) = step ql ts--    userTargetQualLevel (UserBuildTargetSingle _    ) = QL1-    userTargetQualLevel (UserBuildTargetDouble _ _  ) = QL2-    userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3--    step  :: QualLevel -> [BuildTarget]-          -> ([BuildTarget], [(UserBuildTarget, BuildTarget)])-    step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb))-            . partition (\g -> length g > 1)-            . groupBy (equating fst)-            . sortBy (comparing fst)-            . map (\t -> (renderBuildTarget ql t pkgid, t))--data QualLevel = QL1 | QL2 | QL3-  deriving (Enum, Show)--renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget-renderBuildTarget ql target pkgid =-    case ql of-      QL1 -> UserBuildTargetSingle s1        where  s1          = single target-      QL2 -> UserBuildTargetDouble s1 s2     where (s1, s2)     = double target-      QL3 -> UserBuildTargetTriple s1 s2 s3  where (s1, s2, s3) = triple target--  where-    single (BuildTargetComponent cn  ) = dispCName cn-    single (BuildTargetModule    _  m) = prettyShow m-    single (BuildTargetFile      _  f) = f--    double (BuildTargetComponent cn  ) = (dispKind cn, dispCName cn)-    double (BuildTargetModule    cn m) = (dispCName cn, prettyShow m)-    double (BuildTargetFile      cn f) = (dispCName cn, f)--    triple (BuildTargetComponent _   ) = error "triple BuildTargetComponent"-    triple (BuildTargetModule    cn m) = (dispKind cn, dispCName cn, prettyShow m)-    triple (BuildTargetFile      cn f) = (dispKind cn, dispCName cn, f)--    dispCName = componentStringName pkgid-    dispKind  = showComponentKindShort . componentKind--reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO ()-reportBuildTargetProblems verbosity problems = do--    case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of-      []      -> return ()-      targets ->-        die' verbosity $ unlines-          [    "Unrecognised build target '" ++ showUserBuildTarget target-            ++ "'.\n"-            ++ "Expected a " ++ intercalate " or " expected-            ++ ", rather than '" ++ got ++ "'."-          | (target, expected, got) <- targets ]--    case [ (t, e) | BuildTargetNoSuch t e <- problems ] of-      []      -> return ()-      targets ->-        die' verbosity $ unlines-          [    "Unknown build target '" ++ showUserBuildTarget target-            ++ "'.\nThere is no "-            ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'"-                                  | (thing, got) <- nosuch ] ++ "."-          | (target, nosuch) <- targets ]-        where-          mungeThing "file" = "file target"-          mungeThing thing  = thing--    case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of-      []      -> return ()-      targets ->-        die' verbosity $ unlines-          [    "Ambiguous build target '" ++ showUserBuildTarget target-            ++ "'. It could be:\n "-            ++ unlines [ "   "++ showUserBuildTarget ut ++-                         " (" ++ showBuildTargetKind bt ++ ")"-                       | (ut, bt) <- amb ]-          | (target, amb) <- targets ]--  where-    showBuildTargetKind (BuildTargetComponent _  ) = "component"-    showBuildTargetKind (BuildTargetModule    _ _) = "module"-    showBuildTargetKind (BuildTargetFile      _ _) = "file"---------------------------------------- Top level BuildTarget matcher-----matchBuildTarget :: PackageDescription-                 -> UserBuildTarget -> Bool -> Match BuildTarget-matchBuildTarget pkg = \utarget fexists ->-    case utarget of-      UserBuildTargetSingle str1 ->-        matchBuildTarget1 cinfo str1 fexists--      UserBuildTargetDouble str1 str2 ->-        matchBuildTarget2 cinfo str1 str2 fexists--      UserBuildTargetTriple str1 str2 str3 ->-        matchBuildTarget3 cinfo str1 str2 str3 fexists-  where-    cinfo = pkgComponentInfo pkg--matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget-matchBuildTarget1 cinfo str1 fexists =-                        matchComponent1 cinfo str1-   `matchPlusShadowing` matchModule1    cinfo str1-   `matchPlusShadowing` matchFile1      cinfo str1 fexists---matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool-                  -> Match BuildTarget-matchBuildTarget2 cinfo str1 str2 fexists =-                        matchComponent2 cinfo str1 str2-   `matchPlusShadowing` matchModule2    cinfo str1 str2-   `matchPlusShadowing` matchFile2      cinfo str1 str2 fexists---matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool-                  -> Match BuildTarget-matchBuildTarget3 cinfo str1 str2 str3 fexists =-                        matchModule3    cinfo str1 str2 str3-   `matchPlusShadowing` matchFile3      cinfo str1 str2 str3 fexists---data ComponentInfo = ComponentInfo {-       cinfoName    :: ComponentName,-       cinfoStrName :: ComponentStringName,-       cinfoSrcDirs :: [FilePath],-       cinfoModules :: [ModuleName],-       cinfoHsFiles :: [FilePath],   -- other hs files (like main.hs)-       cinfoAsmFiles:: [FilePath],-       cinfoCmmFiles:: [FilePath],-       cinfoCFiles  :: [FilePath],-       cinfoCxxFiles:: [FilePath],-       cinfoJsFiles :: [FilePath]-     }--type ComponentStringName = String--pkgComponentInfo :: PackageDescription -> [ComponentInfo]-pkgComponentInfo pkg =-    [ ComponentInfo {-        cinfoName    = componentName c,-        cinfoStrName = componentStringName pkg (componentName c),-        cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi,-        cinfoModules = componentModules c,-        cinfoHsFiles = componentHsFiles c,-        cinfoAsmFiles= asmSources bi,-        cinfoCmmFiles= cmmSources bi,-        cinfoCFiles  = cSources bi,-        cinfoCxxFiles= cxxSources bi,-        cinfoJsFiles = jsSources bi-      }-    | c <- pkgComponents pkg-    , let bi = componentBuildInfo c ]--componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName-componentStringName pkg (CLibName LMainLibName      ) = prettyShow (packageName pkg)-componentStringName _   (CLibName (LSubLibName name)) = unUnqualComponentName name-componentStringName _   (CFLibName  name) = unUnqualComponentName name-componentStringName _   (CExeName   name) = unUnqualComponentName name-componentStringName _   (CTestName  name) = unUnqualComponentName name-componentStringName _   (CBenchName name) = unUnqualComponentName name--componentModules :: Component -> [ModuleName]--- TODO: Use of 'explicitLibModules' here is a bit wrong:--- a user could very well ask to build a specific signature--- that was inherited from other packages.  To fix this--- we have to plumb 'LocalBuildInfo' through this code.--- Fortunately, this is only used by 'pkgComponentInfo'--- Please don't export this function unless you plan on fixing--- this.-componentModules (CLib   lib)   = explicitLibModules lib-componentModules (CFLib  flib)  = foreignLibModules flib-componentModules (CExe   exe)   = exeModules exe-componentModules (CTest  test)  = testModules test-componentModules (CBench bench) = benchmarkModules bench--componentHsFiles :: Component -> [FilePath]-componentHsFiles (CExe exe) = [modulePath exe]-componentHsFiles (CTest  TestSuite {-                           testInterface = TestSuiteExeV10 _ mainfile-                         }) = [mainfile]-componentHsFiles (CBench Benchmark {-                           benchmarkInterface = BenchmarkExeV10 _ mainfile-                         }) = [mainfile]-componentHsFiles _          = []--{--ex_cs :: [ComponentInfo]-ex_cs =-  [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])-  , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])-  ]-    where-    mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms)-    mkMn :: String -> ModuleName-    mkMn  = fromJust . simpleParse-    pkgid :: PackageIdentifier-    Just pkgid = simpleParse "thelib"--}----------------------------------- Matching component kinds-----data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind-  deriving (Eq, Ord, Show, Enum, Bounded)--componentKind :: ComponentName -> ComponentKind-componentKind (CLibName   _) = LibKind-componentKind (CFLibName  _) = FLibKind-componentKind (CExeName   _) = ExeKind-componentKind (CTestName  _) = TestKind-componentKind (CBenchName _) = BenchKind--cinfoKind :: ComponentInfo -> ComponentKind-cinfoKind = componentKind . cinfoName--matchComponentKind :: String -> Match ComponentKind-matchComponentKind s-  | s `elem` ["lib", "library"]                 = return' LibKind-  | s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind-  | s `elem` ["exe", "executable"]              = return' ExeKind-  | s `elem` ["tst", "test", "test-suite"]      = return' TestKind-  | s `elem` ["bench", "benchmark"]             = return' BenchKind-  | otherwise = matchErrorExpected "component kind" s-  where-    return' ck = increaseConfidence >> return ck--showComponentKind :: ComponentKind -> String-showComponentKind LibKind   = "library"-showComponentKind FLibKind  = "foreign-library"-showComponentKind ExeKind   = "executable"-showComponentKind TestKind  = "test-suite"-showComponentKind BenchKind = "benchmark"--showComponentKindShort :: ComponentKind -> String-showComponentKindShort LibKind   = "lib"-showComponentKindShort FLibKind  = "flib"-showComponentKindShort ExeKind   = "exe"-showComponentKindShort TestKind  = "test"-showComponentKindShort BenchKind = "bench"----------------------------------- Matching component targets-----matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget-matchComponent1 cs = \str1 -> do-    guardComponentName str1-    c <- matchComponentName cs str1-    return (BuildTargetComponent (cinfoName c))--matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget-matchComponent2 cs = \str1 str2 -> do-    ckind <- matchComponentKind str1-    guardComponentName str2-    c <- matchComponentKindAndName cs ckind str2-    return (BuildTargetComponent (cinfoName c))---- utils:--guardComponentName :: String -> Match ()-guardComponentName s-  | all validComponentChar s-    && not (null s)  = increaseConfidence-  | otherwise        = matchErrorExpected "component name" s-  where-    validComponentChar c = isAlphaNum c || c == '.'-                        || c == '_' || c == '-' || c == '\''--matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo-matchComponentName cs str =-    orNoSuchThing "component" str-  $ increaseConfidenceFor-  $ matchInexactly caseFold-      [ (cinfoStrName c, c) | c <- cs ]-      str--matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String-                          -> Match ComponentInfo-matchComponentKindAndName cs ckind str =-    orNoSuchThing (showComponentKind ckind ++ " component") str-  $ increaseConfidenceFor-  $ matchInexactly (\(ck, cn) -> (ck, caseFold cn))-      [ ((cinfoKind c, cinfoStrName c), c) | c <- cs ]-      (ckind, str)------------------------------------ Matching module targets-----matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget-matchModule1 cs = \str1 -> do-    guardModuleName str1-    nubMatchErrors $ do-      c <- tryEach cs-      let ms = cinfoModules c-      m <- matchModuleName ms str1-      return (BuildTargetModule (cinfoName c) m)--matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget-matchModule2 cs = \str1 str2 -> do-    guardComponentName str1-    guardModuleName    str2-    c <- matchComponentName cs str1-    let ms = cinfoModules c-    m <- matchModuleName ms str2-    return (BuildTargetModule (cinfoName c) m)--matchModule3 :: [ComponentInfo] -> String -> String -> String-             -> Match BuildTarget-matchModule3 cs str1 str2 str3 = do-    ckind <- matchComponentKind str1-    guardComponentName str2-    c <- matchComponentKindAndName cs ckind str2-    guardModuleName    str3-    let ms = cinfoModules c-    m <- matchModuleName ms str3-    return (BuildTargetModule (cinfoName c) m)---- utils:--guardModuleName :: String -> Match ()-guardModuleName s-  | all validModuleChar s-    && not (null s)       = increaseConfidence-  | otherwise             = matchErrorExpected "module name" s-  where-    validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''--matchModuleName :: [ModuleName] -> String -> Match ModuleName-matchModuleName ms str =-    orNoSuchThing "module" str-  $ increaseConfidenceFor-  $ matchInexactly caseFold-      [ (prettyShow m, m)-      | m <- ms ]-      str------------------------------------ Matching file targets-----matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget-matchFile1 cs str1 exists =-    nubMatchErrors $ do-      c <- tryEach cs-      filepath <- matchComponentFile c str1 exists-      return (BuildTargetFile (cinfoName c) filepath)---matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget-matchFile2 cs str1 str2 exists = do-    guardComponentName str1-    c <- matchComponentName cs str1-    filepath <- matchComponentFile c str2 exists-    return (BuildTargetFile (cinfoName c) filepath)---matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool-           -> Match BuildTarget-matchFile3 cs str1 str2 str3 exists = do-    ckind <- matchComponentKind str1-    guardComponentName str2-    c <- matchComponentKindAndName cs ckind str2-    filepath <- matchComponentFile c str3 exists-    return (BuildTargetFile (cinfoName c) filepath)---matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath-matchComponentFile c str fexists =-    expecting "file" str $-      matchPlus-        (matchFileExists str fexists)-        (matchPlusShadowing-          (msum [ matchModuleFileRooted   dirs ms      str-                , matchOtherFileRooted    dirs hsFiles str ])-          (msum [ matchModuleFileUnrooted      ms      str-                , matchOtherFileUnrooted       hsFiles str-                , matchOtherFileUnrooted       cFiles  str-                , matchOtherFileUnrooted       jsFiles str ]))-  where-    dirs = cinfoSrcDirs c-    ms   = cinfoModules c-    hsFiles = cinfoHsFiles c-    cFiles  = cinfoCFiles c-    jsFiles = cinfoJsFiles c----- utils--matchFileExists :: FilePath -> Bool -> Match a-matchFileExists _     False = mzero-matchFileExists fname True  = do increaseConfidence-                                 matchErrorNoSuch "file" fname--matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath-matchModuleFileUnrooted ms str = do-    let filepath = normalise str-    _ <- matchModuleFileStem ms filepath-    return filepath--matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath-matchModuleFileRooted dirs ms str = nubMatches $ do-    let filepath = normalise str-    filepath' <- matchDirectoryPrefix dirs filepath-    _ <- matchModuleFileStem ms filepath'-    return filepath--matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName-matchModuleFileStem ms =-      increaseConfidenceFor-    . matchInexactly caseFold-        [ (toFilePath m, m) | m <- ms ]-    . dropExtension--matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath-matchOtherFileRooted dirs fs str = do-    let filepath = normalise str-    filepath' <- matchDirectoryPrefix dirs filepath-    _ <- matchFile fs filepath'-    return filepath--matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath-matchOtherFileUnrooted fs str = do-    let filepath = normalise str-    _ <- matchFile fs filepath-    return filepath--matchFile :: [FilePath] -> FilePath -> Match FilePath-matchFile fs = increaseConfidenceFor-             . matchInexactly caseFold [ (f, f) | f <- fs ]--matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath-matchDirectoryPrefix dirs filepath =-    exactMatches $-      catMaybes-       [ stripDirectory (normalise dir) filepath | dir <- dirs ]-  where-    stripDirectory :: FilePath -> FilePath -> Maybe FilePath-    stripDirectory dir fp =-      joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp)------------------------------------ Matching monad------- | A matcher embodies a way to match some input as being some recognised--- value. In particular it deals with multiple and ambiguous matches.------ There are various matcher primitives ('matchExactly', 'matchInexactly'),--- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can--- run a matcher against an input using 'findMatch'.-----data Match a = NoMatch      Confidence [MatchError]-             | ExactMatch   Confidence [a]-             | InexactMatch Confidence [a]-  deriving Show--type Confidence = Int--data MatchError = MatchErrorExpected String String-                | MatchErrorNoSuch   String String-  deriving (Show, Eq)---instance Alternative Match where-      empty = mzero-      (<|>) = mplus--instance MonadPlus Match where-  mzero = matchZero-  mplus = matchPlus--matchZero :: Match a-matchZero = NoMatch 0 []---- | Combine two matchers. Exact matches are used over inexact matches--- but if we have multiple exact, or inexact then the we collect all the--- ambiguous matches.----matchPlus :: Match a -> Match a -> Match a-matchPlus   (ExactMatch   d1 xs)   (ExactMatch   d2 xs') =-  ExactMatch (max d1 d2) (xs ++ xs')-matchPlus a@(ExactMatch   _  _ )   (InexactMatch _  _  ) = a-matchPlus a@(ExactMatch   _  _ )   (NoMatch      _  _  ) = a-matchPlus   (InexactMatch _  _ ) b@(ExactMatch   _  _  ) = b-matchPlus   (InexactMatch d1 xs)   (InexactMatch d2 xs') =-  InexactMatch (max d1 d2) (xs ++ xs')-matchPlus a@(InexactMatch _  _ )   (NoMatch      _  _  ) = a-matchPlus   (NoMatch      _  _ ) b@(ExactMatch   _  _  ) = b-matchPlus   (NoMatch      _  _ ) b@(InexactMatch _  _  ) = b-matchPlus a@(NoMatch      d1 ms) b@(NoMatch      d2 ms')-                                             | d1 >  d2  = a-                                             | d1 <  d2  = b-                                             | otherwise = NoMatch d1 (ms ++ ms')---- | Combine two matchers. This is similar to 'ambiguousWith' with the--- difference that an exact match from the left matcher shadows any exact--- match on the right. Inexact matches are still collected however.----matchPlusShadowing :: Match a -> Match a -> Match a-matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a-matchPlusShadowing a                   b               = matchPlus a b--instance Functor Match where-  fmap _ (NoMatch      d ms) = NoMatch      d ms-  fmap f (ExactMatch   d xs) = ExactMatch   d (fmap f xs)-  fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)--instance Applicative Match where-  pure a = ExactMatch 0 [a]-  (<*>) = ap--instance Monad Match where-  return = pure--  NoMatch      d ms >>= _ = NoMatch d ms-  ExactMatch   d xs >>= f = addDepth d-                          $ foldr matchPlus matchZero (map f xs)-  InexactMatch d xs >>= f = addDepth d .  forceInexact-                          $ foldr matchPlus matchZero (map f xs)--addDepth :: Confidence -> Match a -> Match a-addDepth d' (NoMatch      d msgs) = NoMatch      (d'+d) msgs-addDepth d' (ExactMatch   d xs)   = ExactMatch   (d'+d) xs-addDepth d' (InexactMatch d xs)   = InexactMatch (d'+d) xs--forceInexact :: Match a -> Match a-forceInexact (ExactMatch d ys) = InexactMatch d ys-forceInexact m                 = m----------------------------------- Various match primitives-----matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a-matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got]-matchErrorNoSuch   thing got = NoMatch 0 [MatchErrorNoSuch   thing got]--expecting :: String -> String -> Match a -> Match a-expecting thing got (NoMatch 0 _) = matchErrorExpected thing got-expecting _     _   m             = m--orNoSuchThing :: String -> String -> Match a -> Match a-orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got-orNoSuchThing _     _   m             = m--increaseConfidence :: Match ()-increaseConfidence = ExactMatch 1 [()]--increaseConfidenceFor :: Match a -> Match a-increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r--nubMatches :: Eq a => Match a -> Match a-nubMatches (NoMatch      d msgs) = NoMatch      d msgs-nubMatches (ExactMatch   d xs)   = ExactMatch   d (nub xs)-nubMatches (InexactMatch d xs)   = InexactMatch d (nub xs)--nubMatchErrors :: Match a -> Match a-nubMatchErrors (NoMatch      d msgs) = NoMatch      d (nub msgs)-nubMatchErrors (ExactMatch   d xs)   = ExactMatch   d xs-nubMatchErrors (InexactMatch d xs)   = InexactMatch d xs---- | Lift a list of matches to an exact match.----exactMatches, inexactMatches :: [a] -> Match a--exactMatches [] = matchZero-exactMatches xs = ExactMatch 0 xs--inexactMatches [] = matchZero-inexactMatches xs = InexactMatch 0 xs--tryEach :: [a] -> Match a-tryEach = exactMatches------------------------------------ Top level match runner------- | Given a matcher and a key to look up, use the matcher to find all the--- possible matches. There may be 'None', a single 'Unambiguous' match or--- you may have an 'Ambiguous' match with several possibilities.----findMatch :: Eq b => Match b -> MaybeAmbiguous b-findMatch match =-    case match of-      NoMatch    _ msgs -> None (nub msgs)-      ExactMatch   _ xs -> checkAmbiguous xs-      InexactMatch _ xs -> checkAmbiguous xs-  where-    checkAmbiguous xs = case nub xs of-                          [x] -> Unambiguous x-                          xs' -> Ambiguous   xs'--data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a]-  deriving Show------------------------------------ Basic matchers-----{---- | A primitive matcher that looks up a value in a finite 'Map'. The--- value must match exactly.----matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b)-matchExactly xs =-    \x -> case Map.lookup x m of-            Nothing -> matchZero-            Just ys -> ExactMatch 0 ys-  where-    m :: Ord a => Map a [b]-    m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]--}---- | A primitive matcher that looks up a value in a finite 'Map'. It checks--- for an exact or inexact match. We get an inexact match if the match--- is not exact, but the canonical forms match. It takes a canonicalisation--- function for this purpose.------ So for example if we used string case fold as the canonicalisation--- function, then we would get case insensitive matching (but it will still--- report an exact match when the case matches too).----matchInexactly :: (Ord a, Ord a') =>-                        (a -> a') ->-                        [(a, b)] -> (a -> Match b)-matchInexactly 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-  where-    m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]--    -- the map of canonicalised keys to groups of inexact matches-    m' = Map.mapKeysWith (++) cannonicalise m------------------------------------- Utils-----caseFold :: String -> String-caseFold = lowercase----- | Check that the given build targets are valid in the current context.------ Also swizzle into a more convenient form.----checkBuildTargets :: Verbosity -> PackageDescription -> LocalBuildInfo -> [BuildTarget]-                  -> IO [TargetInfo]-checkBuildTargets _ pkg_descr lbi []      =-    return (allTargetsInBuildOrder' pkg_descr lbi)--checkBuildTargets verbosity pkg_descr lbi targets = do--    let (enabled, disabled) =-          partitionEithers-            [ case componentDisabledReason (componentEnabledSpec lbi) comp of-                Nothing     -> Left  target'-                Just reason -> Right (cname, reason)-            | target <- targets-            , let target'@(cname,_) = swizzleTarget target-            , let comp = getComponent pkg_descr cname ]--    case disabled of-      []                 -> return ()-      ((cname,reason):_) -> die' verbosity $ formatReason (showComponentName cname) reason--    for_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) ->-      warn verbosity $ "Ignoring '" ++ either prettyShow id t ++ ". The whole "-                    ++ showComponentName c ++ " will be processed. (Support for "-                    ++ "module and file targets has not been implemented yet.)"--    -- Pick out the actual CLBIs for each of these cnames-    enabled' <- for enabled $ \(cname, _) -> do-        case componentNameTargets' pkg_descr lbi cname of-            [] -> error "checkBuildTargets: nothing enabled"-            [target] -> return target-            _targets -> error "checkBuildTargets: multiple copies enabled"--    return enabled'--  where-    swizzleTarget (BuildTargetComponent c)   = (c, Nothing)-    swizzleTarget (BuildTargetModule    c m) = (c, Just (Left  m))-    swizzleTarget (BuildTargetFile      c f) = (c, Just (Right f))--    formatReason cn DisabledComponent =-        "Cannot process the " ++ cn ++ " because the component is marked "-     ++ "as disabled in the .cabal file."-    formatReason cn DisabledAllTests =-        "Cannot process the " ++ cn ++ " because test suites are not "-     ++ "enabled. Run configure with the flag --enable-tests"-    formatReason cn DisabledAllBenchmarks =-        "Cannot process the " ++ cn ++ " because benchmarks are not "-     ++ "enabled. Re-run configure with the flag --enable-benchmarks"-    formatReason cn (DisabledAllButOne cn') =-        "Cannot process the " ++ cn ++ " because this package was "-     ++ "configured only to build " ++ cn' ++ ". Re-run configure "-     ++ "with the argument " ++ cn+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Client.BuildTargets+-- Copyright   :  (c) Duncan Coutts 2012+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+--+-- Handling for user-specified build targets+module Distribution.Simple.BuildTarget+  ( -- * Main interface+    readTargetInfos+  , readBuildTargets -- in case you don't have LocalBuildInfo++    -- * Build targets+  , BuildTarget (..)+  , showBuildTarget+  , QualLevel (..)+  , buildTargetComponentName++    -- * Parsing user build targets+  , UserBuildTarget+  , readUserBuildTargets+  , showUserBuildTarget+  , UserBuildTargetProblem (..)+  , reportUserBuildTargetProblems++    -- * Resolving build targets+  , resolveBuildTargets+  , BuildTargetProblem (..)+  , reportBuildTargetProblems+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.ForeignLib+import Distribution.Types.LocalBuildInfo+import Distribution.Types.TargetInfo+import Distribution.Types.UnqualComponentName++import qualified Distribution.Compat.CharParsing as P+import Distribution.ModuleName+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Parsec+import Distribution.Pretty+import Distribution.Simple.Errors+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Utils+import Distribution.Utils.Path+import Distribution.Verbosity++import Control.Arrow ((&&&))+import Control.Monad (msum)+import Data.List (groupBy, stripPrefix)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import System.Directory (doesDirectoryExist, doesFileExist)+import System.FilePath as FilePath+  ( dropExtension+  , hasTrailingPathSeparator+  , joinPath+  , normalise+  , splitDirectories+  , splitPath+  )++-- | Take a list of 'String' build targets, and parse and validate them+-- into actual 'TargetInfo's to be built/registered/whatever.+readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo]+readTargetInfos verbosity pkg_descr lbi args = do+  build_targets <- readBuildTargets verbosity pkg_descr args+  checkBuildTargets verbosity pkg_descr lbi build_targets++-- ------------------------------------------------------------++-- * User build targets++-- ------------------------------------------------------------++-- | Various ways that a user may specify a build target.+data UserBuildTarget+  = -- | A target specified by a single name. This could be a component+    -- module or file.+    --+    -- > cabal build foo+    -- > cabal build Data.Foo+    -- > cabal build Data/Foo.hs  Data/Foo.hsc+    UserBuildTargetSingle String+  | -- | A target specified by a qualifier and name. This could be a component+    -- name qualified by the component namespace kind, or a module or file+    -- qualified by the component name.+    --+    -- > cabal build lib:foo exe:foo+    -- > cabal build foo:Data.Foo+    -- > cabal build foo:Data/Foo.hs+    UserBuildTargetDouble String String+  | -- | A fully qualified target, either a module or file qualified by a+    -- component name with the component namespace kind.+    --+    -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs+    -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo+    UserBuildTargetTriple String String String+  deriving (Show, Eq, Ord)++-- ------------------------------------------------------------++-- * Resolved build targets++-- ------------------------------------------------------------++-- | A fully resolved build target.+data BuildTarget+  = -- | A specific component+    BuildTargetComponent ComponentName+  | -- | A specific module within a specific component.+    BuildTargetModule ComponentName ModuleName+  | -- | A specific file within a specific component.+    BuildTargetFile ComponentName FilePath+  deriving (Eq, Show, Generic)++instance Binary BuildTarget++buildTargetComponentName :: BuildTarget -> ComponentName+buildTargetComponentName (BuildTargetComponent cn) = cn+buildTargetComponentName (BuildTargetModule cn _) = cn+buildTargetComponentName (BuildTargetFile cn _) = cn++-- | Read a list of user-supplied build target strings and resolve them to+-- 'BuildTarget's according to a 'PackageDescription'. If there are problems+-- with any of the targets e.g. they don't exist or are misformatted, throw an+-- 'IOException'.+readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget]+readBuildTargets verbosity pkg targetStrs = do+  let (uproblems, utargets) = readUserBuildTargets targetStrs+  reportUserBuildTargetProblems verbosity uproblems++  utargets' <- traverse checkTargetExistsAsFile utargets++  let (bproblems, btargets) = resolveBuildTargets pkg utargets'+  reportBuildTargetProblems verbosity bproblems++  return btargets++checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)+checkTargetExistsAsFile t = do+  fexists <- existsAsFile (fileComponentOfTarget t)+  return (t, fexists)+  where+    existsAsFile f = do+      exists <- doesFileExist f+      case splitPath f of+        (d : _) | hasTrailingPathSeparator d -> doesDirectoryExist d+        (d : _ : _) | not exists -> doesDirectoryExist d+        _ -> return exists++    fileComponentOfTarget (UserBuildTargetSingle s1) = s1+    fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2+    fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3++-- ------------------------------------------------------------++-- * Parsing user targets++-- ------------------------------------------------------------++readUserBuildTargets+  :: [String]+  -> ( [UserBuildTargetProblem]+     , [UserBuildTarget]+     )+readUserBuildTargets = partitionEithers . map readUserBuildTarget++-- |+--+-- >>> readUserBuildTarget "comp"+-- Right (UserBuildTargetSingle "comp")+--+-- >>> readUserBuildTarget "lib:comp"+-- Right (UserBuildTargetDouble "lib" "comp")+--+-- >>> readUserBuildTarget "pkg:lib:comp"+-- Right (UserBuildTargetTriple "pkg" "lib" "comp")+--+-- >>> readUserBuildTarget "\"comp\""+-- Right (UserBuildTargetSingle "comp")+--+-- >>> readUserBuildTarget "lib:\"comp\""+-- Right (UserBuildTargetDouble "lib" "comp")+--+-- >>> readUserBuildTarget "pkg:lib:\"comp\""+-- Right (UserBuildTargetTriple "pkg" "lib" "comp")+--+-- >>> readUserBuildTarget "pkg:lib:comp:more"+-- Left (UserBuildTargetUnrecognised "pkg:lib:comp:more")+--+-- >>> readUserBuildTarget "pkg:\"lib\":comp"+-- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp")+readUserBuildTarget+  :: String+  -> Either+      UserBuildTargetProblem+      UserBuildTarget+readUserBuildTarget targetstr =+  case explicitEitherParsec parseTargetApprox targetstr of+    Left _ -> Left (UserBuildTargetUnrecognised targetstr)+    Right tgt -> Right tgt+  where+    parseTargetApprox :: CabalParsing m => m UserBuildTarget+    parseTargetApprox = do+      -- read one, two, or three tokens, where last could be "hs-string"+      ts <- tokens+      return $ case ts of+        (a, Nothing) -> UserBuildTargetSingle a+        (a, Just (b, Nothing)) -> UserBuildTargetDouble a b+        (a, Just (b, Just c)) -> UserBuildTargetTriple a b c++    tokens :: CabalParsing m => m (String, Maybe (String, Maybe String))+    tokens =+      (\s -> (s, Nothing)) <$> parsecHaskellString+        <|> (,) <$> token <*> P.optional (P.char ':' *> tokens2)++    tokens2 :: CabalParsing m => m (String, Maybe String)+    tokens2 =+      (\s -> (s, Nothing)) <$> parsecHaskellString+        <|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token))++    token :: CabalParsing m => m String+    token = P.munch1 (\x -> not (isSpace x) && x /= ':')++data UserBuildTargetProblem+  = UserBuildTargetUnrecognised String+  deriving (Show)++reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO ()+reportUserBuildTargetProblems verbosity problems = do+  case [target | UserBuildTargetUnrecognised target <- problems] of+    [] -> return ()+    target ->+      dieWithException verbosity $+        UnrecognisedBuildTarget target++showUserBuildTarget :: UserBuildTarget -> String+showUserBuildTarget = intercalate ":" . getComponents+  where+    getComponents (UserBuildTargetSingle s1) = [s1]+    getComponents (UserBuildTargetDouble s1 s2) = [s1, s2]+    getComponents (UserBuildTargetTriple s1 s2 s3) = [s1, s2, s3]++-- | Unless you use 'QL1', this function is PARTIAL;+-- use 'showBuildTarget' instead.+showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String+showBuildTarget' ql pkgid bt =+  showUserBuildTarget (renderBuildTarget ql bt pkgid)++-- | Unambiguously render a 'BuildTarget', so that it can+-- be parsed in all situations.+showBuildTarget :: PackageId -> BuildTarget -> String+showBuildTarget pkgid t =+  showBuildTarget' (qlBuildTarget t) pkgid t+  where+    qlBuildTarget BuildTargetComponent{} = QL2+    qlBuildTarget _ = QL3++-- ------------------------------------------------------------++-- * Resolving user targets to build targets++-- ------------------------------------------------------------++{-+stargets =+  [ BuildTargetComponent (CExeName "foo")+  , BuildTargetModule    (CExeName "foo") (mkMn "Foo")+  , BuildTargetModule    (CExeName "tst") (mkMn "Foo")+  ]+    where+    mkMn :: String -> ModuleName+    mkMn  = fromJust . simpleParse++ex_pkgid :: PackageIdentifier+Just ex_pkgid = simpleParse "thelib"+-}++-- | Given a bunch of user-specified targets, try to resolve what it is they+-- refer to.+resolveBuildTargets+  :: PackageDescription+  -> [(UserBuildTarget, Bool)]+  -> ([BuildTargetProblem], [BuildTarget])+resolveBuildTargets pkg =+  partitionEithers+    . map (uncurry (resolveBuildTarget pkg))++resolveBuildTarget+  :: PackageDescription+  -> UserBuildTarget+  -> Bool+  -> Either BuildTargetProblem BuildTarget+resolveBuildTarget pkg userTarget fexists =+  case findMatch (matchBuildTarget pkg userTarget fexists) of+    Unambiguous target -> Right target+    Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets')+      where+        targets' =+          disambiguateBuildTargets+            (packageId pkg)+            userTarget+            targets+    None errs -> Left (classifyMatchErrors errs)+  where+    classifyMatchErrors errs+      | Just expected' <- NE.nonEmpty expected =+          let unzip' = fmap fst &&& fmap snd+              (things, got :| _) = unzip' expected'+           in BuildTargetExpected userTarget (NE.toList things) got+      | not (null nosuch) = BuildTargetNoSuch userTarget nosuch+      | otherwise = error $ "resolveBuildTarget: internal error in matching"+      where+        expected = [(thing, got) | MatchErrorExpected thing got <- errs]+        nosuch = [(thing, got) | MatchErrorNoSuch thing got <- errs]++data BuildTargetProblem+  = -- |  [expected thing] (actually got)+    BuildTargetExpected UserBuildTarget [String] String+  | -- | [(no such thing,  actually got)]+    BuildTargetNoSuch UserBuildTarget [(String, String)]+  | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)]+  deriving (Show)++disambiguateBuildTargets+  :: PackageId+  -> UserBuildTarget+  -> [BuildTarget]+  -> [(UserBuildTarget, BuildTarget)]+disambiguateBuildTargets pkgid original =+  disambiguate (userTargetQualLevel original)+  where+    disambiguate ql ts+      | null amb = unamb+      | otherwise = unamb ++ disambiguate (succ ql) amb+      where+        (amb, unamb) = step ql ts++    userTargetQualLevel (UserBuildTargetSingle _) = QL1+    userTargetQualLevel (UserBuildTargetDouble _ _) = QL2+    userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3++    step+      :: QualLevel+      -> [BuildTarget]+      -> ([BuildTarget], [(UserBuildTarget, BuildTarget)])+    step ql =+      (\(amb, unamb) -> (map snd $ concat amb, concat unamb))+        . partition (\g -> length g > 1)+        . groupBy (equating fst)+        . sortBy (comparing fst)+        . map (\t -> (renderBuildTarget ql t pkgid, t))++data QualLevel = QL1 | QL2 | QL3+  deriving (Enum, Show)++renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget+renderBuildTarget ql target pkgid =+  case ql of+    QL1 -> UserBuildTargetSingle s1 where s1 = single target+    QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target+    QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target+  where+    single (BuildTargetComponent cn) = dispCName cn+    single (BuildTargetModule _ m) = prettyShow m+    single (BuildTargetFile _ f) = f++    double (BuildTargetComponent cn) = (dispKind cn, dispCName cn)+    double (BuildTargetModule cn m) = (dispCName cn, prettyShow m)+    double (BuildTargetFile cn f) = (dispCName cn, f)++    triple (BuildTargetComponent _) = error "triple BuildTargetComponent"+    triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow m)+    triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f)++    dispCName = componentStringName pkgid+    dispKind = showComponentKindShort . componentKind++reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO ()+reportBuildTargetProblems verbosity problems = do+  case [(t, e, g) | BuildTargetExpected t e g <- problems] of+    [] -> return ()+    targets ->+      dieWithException verbosity $+        ReportBuildTargetProblems $+          map (\(target, expected, got) -> (showUserBuildTarget target, expected, got)) targets++  case [(t, e) | BuildTargetNoSuch t e <- problems] of+    [] -> return ()+    targets ->+      dieWithException verbosity $+        UnknownBuildTarget $+          map (\(target, nosuch) -> (showUserBuildTarget target, nosuch)) targets++  case [(t, ts) | BuildTargetAmbiguous t ts <- problems] of+    [] -> return ()+    targets ->+      dieWithException verbosity $+        AmbiguousBuildTarget $+          map+            ( \(target, amb) ->+                ( showUserBuildTarget target+                , (map (\(ut, bt) -> (showUserBuildTarget ut, showBuildTargetKind bt)) amb)+                )+            )+            targets+  where+    showBuildTargetKind (BuildTargetComponent _) = "component"+    showBuildTargetKind (BuildTargetModule _ _) = "module"+    showBuildTargetKind (BuildTargetFile _ _) = "file"++----------------------------------+-- Top level BuildTarget matcher+--++matchBuildTarget+  :: PackageDescription+  -> UserBuildTarget+  -> Bool+  -> Match BuildTarget+matchBuildTarget pkg = \utarget fexists ->+  case utarget of+    UserBuildTargetSingle str1 ->+      matchBuildTarget1 cinfo str1 fexists+    UserBuildTargetDouble str1 str2 ->+      matchBuildTarget2 cinfo str1 str2 fexists+    UserBuildTargetTriple str1 str2 str3 ->+      matchBuildTarget3 cinfo str1 str2 str3 fexists+  where+    cinfo = pkgComponentInfo pkg++matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget+matchBuildTarget1 cinfo str1 fexists =+  matchComponent1 cinfo str1+    `matchPlusShadowing` matchModule1 cinfo str1+    `matchPlusShadowing` matchFile1 cinfo str1 fexists++matchBuildTarget2+  :: [ComponentInfo]+  -> String+  -> String+  -> Bool+  -> Match BuildTarget+matchBuildTarget2 cinfo str1 str2 fexists =+  matchComponent2 cinfo str1 str2+    `matchPlusShadowing` matchModule2 cinfo str1 str2+    `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists++matchBuildTarget3+  :: [ComponentInfo]+  -> String+  -> String+  -> String+  -> Bool+  -> Match BuildTarget+matchBuildTarget3 cinfo str1 str2 str3 fexists =+  matchModule3 cinfo str1 str2 str3+    `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists++data ComponentInfo = ComponentInfo+  { cinfoName :: ComponentName+  , cinfoStrName :: ComponentStringName+  , cinfoSrcDirs :: [FilePath]+  , cinfoModules :: [ModuleName]+  , cinfoHsFiles :: [FilePath] -- other hs files (like main.hs)+  , cinfoAsmFiles :: [FilePath]+  , cinfoCmmFiles :: [FilePath]+  , cinfoCFiles :: [FilePath]+  , cinfoCxxFiles :: [FilePath]+  , cinfoJsFiles :: [FilePath]+  }++type ComponentStringName = String++pkgComponentInfo :: PackageDescription -> [ComponentInfo]+pkgComponentInfo pkg =+  [ ComponentInfo+    { cinfoName = componentName c+    , cinfoStrName = componentStringName pkg (componentName c)+    , cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi+    , cinfoModules = componentModules c+    , cinfoHsFiles = map getSymbolicPath $ componentHsFiles c+    , cinfoAsmFiles = map getSymbolicPath $ asmSources bi+    , cinfoCmmFiles = map getSymbolicPath $ cmmSources bi+    , cinfoCFiles = map getSymbolicPath $ cSources bi+    , cinfoCxxFiles = map getSymbolicPath $ cxxSources bi+    , cinfoJsFiles = map getSymbolicPath $ jsSources bi+    }+  | c <- pkgComponents pkg+  , let bi = componentBuildInfo c+  ]++componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName+componentStringName pkg (CLibName LMainLibName) = prettyShow (packageName pkg)+componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name+componentStringName _ (CFLibName name) = unUnqualComponentName name+componentStringName _ (CExeName name) = unUnqualComponentName name+componentStringName _ (CTestName name) = unUnqualComponentName name+componentStringName _ (CBenchName name) = unUnqualComponentName name++componentModules :: Component -> [ModuleName]+-- TODO: Use of 'explicitLibModules' here is a bit wrong:+-- a user could very well ask to build a specific signature+-- that was inherited from other packages.  To fix this+-- we have to plumb 'LocalBuildInfo' through this code.+-- Fortunately, this is only used by 'pkgComponentInfo'+-- Please don't export this function unless you plan on fixing+-- this.+componentModules (CLib lib) = explicitLibModules lib+componentModules (CFLib flib) = foreignLibModules flib+componentModules (CExe exe) = exeModules exe+componentModules (CTest test) = testModules test+componentModules (CBench bench) = benchmarkModules bench++componentHsFiles :: Component -> [RelativePath Source File]+componentHsFiles (CExe exe) = [modulePath exe]+componentHsFiles+  ( CTest+      TestSuite+        { testInterface = TestSuiteExeV10 _ mainfile+        }+    ) = [mainfile]+componentHsFiles+  ( CBench+      Benchmark+        { benchmarkInterface = BenchmarkExeV10 _ mainfile+        }+    ) = [mainfile]+componentHsFiles _ = []++{-+ex_cs :: [ComponentInfo]+ex_cs =+  [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])+  , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])+  ]+    where+    mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms)+    mkMn :: String -> ModuleName+    mkMn  = fromJust . simpleParse+    pkgid :: PackageIdentifier+    Just pkgid = simpleParse "thelib"+-}++------------------------------+-- Matching component kinds+--++data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind+  deriving (Eq, Ord, Show, Enum, Bounded)++componentKind :: ComponentName -> ComponentKind+componentKind (CLibName _) = LibKind+componentKind (CFLibName _) = FLibKind+componentKind (CExeName _) = ExeKind+componentKind (CTestName _) = TestKind+componentKind (CBenchName _) = BenchKind++cinfoKind :: ComponentInfo -> ComponentKind+cinfoKind = componentKind . cinfoName++matchComponentKind :: String -> Match ComponentKind+matchComponentKind s+  | s `elem` ["lib", "library"] = return' LibKind+  | s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind+  | s `elem` ["exe", "executable"] = return' ExeKind+  | s `elem` ["tst", "test", "test-suite"] = return' TestKind+  | s `elem` ["bench", "benchmark"] = return' BenchKind+  | otherwise = matchErrorExpected "component kind" s+  where+    return' ck = increaseConfidence >> return ck++showComponentKind :: ComponentKind -> String+showComponentKind LibKind = "library"+showComponentKind FLibKind = "foreign-library"+showComponentKind ExeKind = "executable"+showComponentKind TestKind = "test-suite"+showComponentKind BenchKind = "benchmark"++showComponentKindShort :: ComponentKind -> String+showComponentKindShort LibKind = "lib"+showComponentKindShort FLibKind = "flib"+showComponentKindShort ExeKind = "exe"+showComponentKindShort TestKind = "test"+showComponentKindShort BenchKind = "bench"++------------------------------+-- Matching component targets+--++matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget+matchComponent1 cs = \str1 -> do+  guardComponentName str1+  c <- matchComponentName cs str1+  return (BuildTargetComponent (cinfoName c))++matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget+matchComponent2 cs = \str1 str2 -> do+  ckind <- matchComponentKind str1+  guardComponentName str2+  c <- matchComponentKindAndName cs ckind str2+  return (BuildTargetComponent (cinfoName c))++-- utils:++guardComponentName :: String -> Match ()+guardComponentName s+  | all validComponentChar s+      && not (null s) =+      increaseConfidence+  | otherwise = matchErrorExpected "component name" s+  where+    validComponentChar c =+      isAlphaNum c+        || c == '.'+        || c == '_'+        || c == '-'+        || c == '\''++matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo+matchComponentName cs str =+  orNoSuchThing "component" str $+    increaseConfidenceFor $+      matchInexactly+        caseFold+        [(cinfoStrName c, c) | c <- cs]+        str++matchComponentKindAndName+  :: [ComponentInfo]+  -> ComponentKind+  -> String+  -> Match ComponentInfo+matchComponentKindAndName cs ckind str =+  orNoSuchThing (showComponentKind ckind ++ " component") str $+    increaseConfidenceFor $+      matchInexactly+        (\(ck, cn) -> (ck, caseFold cn))+        [((cinfoKind c, cinfoStrName c), c) | c <- cs]+        (ckind, str)++------------------------------+-- Matching module targets+--++matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget+matchModule1 cs = \str1 -> do+  guardModuleName str1+  nubMatchErrors $ do+    c <- tryEach cs+    let ms = cinfoModules c+    m <- matchModuleName ms str1+    return (BuildTargetModule (cinfoName c) m)++matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget+matchModule2 cs = \str1 str2 -> do+  guardComponentName str1+  guardModuleName str2+  c <- matchComponentName cs str1+  let ms = cinfoModules c+  m <- matchModuleName ms str2+  return (BuildTargetModule (cinfoName c) m)++matchModule3+  :: [ComponentInfo]+  -> String+  -> String+  -> String+  -> Match BuildTarget+matchModule3 cs str1 str2 str3 = do+  ckind <- matchComponentKind str1+  guardComponentName str2+  c <- matchComponentKindAndName cs ckind str2+  guardModuleName str3+  let ms = cinfoModules c+  m <- matchModuleName ms str3+  return (BuildTargetModule (cinfoName c) m)++-- utils:++guardModuleName :: String -> Match ()+guardModuleName s+  | all validModuleChar s+      && not (null s) =+      increaseConfidence+  | otherwise = matchErrorExpected "module name" s+  where+    validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''++matchModuleName :: [ModuleName] -> String -> Match ModuleName+matchModuleName ms str =+  orNoSuchThing "module" str $+    increaseConfidenceFor $+      matchInexactly+        caseFold+        [ (prettyShow m, m)+        | m <- ms+        ]+        str++------------------------------+-- Matching file targets+--++matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget+matchFile1 cs str1 exists =+  nubMatchErrors $ do+    c <- tryEach cs+    filepath <- matchComponentFile c str1 exists+    return (BuildTargetFile (cinfoName c) filepath)++matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget+matchFile2 cs str1 str2 exists = do+  guardComponentName str1+  c <- matchComponentName cs str1+  filepath <- matchComponentFile c str2 exists+  return (BuildTargetFile (cinfoName c) filepath)++matchFile3+  :: [ComponentInfo]+  -> String+  -> String+  -> String+  -> Bool+  -> Match BuildTarget+matchFile3 cs str1 str2 str3 exists = do+  ckind <- matchComponentKind str1+  guardComponentName str2+  c <- matchComponentKindAndName cs ckind str2+  filepath <- matchComponentFile c str3 exists+  return (BuildTargetFile (cinfoName c) filepath)++matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath+matchComponentFile c str fexists =+  expecting "file" str $+    matchPlus+      (matchFileExists str fexists)+      ( matchPlusShadowing+          ( msum+              [ matchModuleFileRooted dirs ms str+              , matchOtherFileRooted dirs hsFiles str+              ]+          )+          ( msum+              [ matchModuleFileUnrooted ms str+              , matchOtherFileUnrooted hsFiles str+              , matchOtherFileUnrooted cFiles str+              , matchOtherFileUnrooted jsFiles str+              ]+          )+      )+  where+    dirs = cinfoSrcDirs c+    ms = cinfoModules c+    hsFiles = cinfoHsFiles c+    cFiles = cinfoCFiles c+    jsFiles = cinfoJsFiles c++-- utils++matchFileExists :: FilePath -> Bool -> Match a+matchFileExists _ False = mzero+matchFileExists fname True = do+  increaseConfidence+  matchErrorNoSuch "file" fname++matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath+matchModuleFileUnrooted ms str = do+  let filepath = normalise str+  _ <- matchModuleFileStem ms filepath+  return filepath++matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath+matchModuleFileRooted dirs ms str = nubMatches $ do+  let filepath = normalise str+  filepath' <- matchDirectoryPrefix dirs filepath+  _ <- matchModuleFileStem ms filepath'+  return filepath++matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName+matchModuleFileStem ms =+  increaseConfidenceFor+    . matchInexactly+      caseFold+      [(toFilePath m, m) | m <- ms]+    . dropExtension++matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath+matchOtherFileRooted dirs fs str = do+  let filepath = normalise str+  filepath' <- matchDirectoryPrefix dirs filepath+  _ <- matchFile fs filepath'+  return filepath++matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath+matchOtherFileUnrooted fs str = do+  let filepath = normalise str+  _ <- matchFile fs filepath+  return filepath++matchFile :: [FilePath] -> FilePath -> Match FilePath+matchFile fs =+  increaseConfidenceFor+    . matchInexactly caseFold [(f, f) | f <- fs]++matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath+matchDirectoryPrefix dirs filepath =+  exactMatches $+    catMaybes+      [stripDirectory (normalise dir) filepath | dir <- dirs]+  where+    stripDirectory :: FilePath -> FilePath -> Maybe FilePath+    stripDirectory dir fp =+      joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp)++------------------------------+-- Matching monad+--++-- | A matcher embodies a way to match some input as being some recognised+-- value. In particular it deals with multiple and ambiguous matches.+--+-- There are various matcher primitives ('matchExactly', 'matchInexactly'),+-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can+-- run a matcher against an input using 'findMatch'.+data Match a+  = NoMatch Confidence [MatchError]+  | ExactMatch Confidence [a]+  | InexactMatch Confidence [a]+  deriving (Show)++type Confidence = Int++data MatchError+  = MatchErrorExpected String String+  | MatchErrorNoSuch String String+  deriving (Show, Eq)++instance Alternative Match where+  empty = mzero+  (<|>) = mplus++instance MonadPlus Match where+  mzero = matchZero+  mplus = matchPlus++matchZero :: Match a+matchZero = NoMatch 0 []++-- | Combine two matchers. Exact matches are used over inexact matches+-- but if we have multiple exact, or inexact then the we collect all the+-- ambiguous matches.+matchPlus :: Match a -> Match a -> Match a+matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') =+  ExactMatch (max d1 d2) (xs ++ xs')+matchPlus a@(ExactMatch _ _) (InexactMatch _ _) = a+matchPlus a@(ExactMatch _ _) (NoMatch _ _) = a+matchPlus (InexactMatch _ _) b@(ExactMatch _ _) = b+matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') =+  InexactMatch (max d1 d2) (xs ++ xs')+matchPlus a@(InexactMatch _ _) (NoMatch _ _) = a+matchPlus (NoMatch _ _) b@(ExactMatch _ _) = b+matchPlus (NoMatch _ _) b@(InexactMatch _ _) = b+matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms')+  | d1 > d2 = a+  | d1 < d2 = b+  | otherwise = NoMatch d1 (ms ++ ms')++-- | Combine two matchers. This is similar to 'ambiguousWith' with the+-- difference that an exact match from the left matcher shadows any exact+-- match on the right. Inexact matches are still collected however.+matchPlusShadowing :: Match a -> Match a -> Match a+matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a+matchPlusShadowing a b = matchPlus a b++instance Functor Match where+  fmap _ (NoMatch d ms) = NoMatch d ms+  fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs)+  fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)++instance Applicative Match where+  pure a = ExactMatch 0 [a]+  (<*>) = ap++instance Monad Match where+  return = pure++  NoMatch d ms >>= _ = NoMatch d ms+  ExactMatch d xs >>= f =+    addDepth d $+      foldr matchPlus matchZero (map f xs)+  InexactMatch d xs >>= f =+    addDepth d . forceInexact $+      foldr matchPlus matchZero (map f xs)++addDepth :: Confidence -> Match a -> Match a+addDepth d' (NoMatch d msgs) = NoMatch (d' + d) msgs+addDepth d' (ExactMatch d xs) = ExactMatch (d' + d) xs+addDepth d' (InexactMatch d xs) = InexactMatch (d' + d) xs++forceInexact :: Match a -> Match a+forceInexact (ExactMatch d ys) = InexactMatch d ys+forceInexact m = m++------------------------------+-- Various match primitives+--++matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a+matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got]+matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got]++expecting :: String -> String -> Match a -> Match a+expecting thing got (NoMatch 0 _) = matchErrorExpected thing got+expecting _ _ m = m++orNoSuchThing :: String -> String -> Match a -> Match a+orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got+orNoSuchThing _ _ m = m++increaseConfidence :: Match ()+increaseConfidence = ExactMatch 1 [()]++increaseConfidenceFor :: Match a -> Match a+increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r++nubMatches :: Eq a => Match a -> Match a+nubMatches (NoMatch d msgs) = NoMatch d msgs+nubMatches (ExactMatch d xs) = ExactMatch d (nub xs)+nubMatches (InexactMatch d xs) = InexactMatch d (nub xs)++nubMatchErrors :: Match a -> Match a+nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs)+nubMatchErrors (ExactMatch d xs) = ExactMatch d xs+nubMatchErrors (InexactMatch d xs) = InexactMatch d xs++-- | Lift a list of matches to an exact match.+exactMatches, inexactMatches :: [a] -> Match a+exactMatches [] = matchZero+exactMatches xs = ExactMatch 0 xs+inexactMatches [] = matchZero+inexactMatches xs = InexactMatch 0 xs++tryEach :: [a] -> Match a+tryEach = exactMatches++------------------------------+-- Top level match runner+--++-- | Given a matcher and a key to look up, use the matcher to find all the+-- possible matches. There may be 'None', a single 'Unambiguous' match or+-- you may have an 'Ambiguous' match with several possibilities.+findMatch :: Eq b => Match b -> MaybeAmbiguous b+findMatch match =+  case match of+    NoMatch _ msgs -> None (nub msgs)+    ExactMatch _ xs -> checkAmbiguous xs+    InexactMatch _ xs -> checkAmbiguous xs+  where+    checkAmbiguous xs = case nub xs of+      [x] -> Unambiguous x+      xs' -> Ambiguous xs'++data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a]+  deriving (Show)++------------------------------+-- Basic matchers+--++{-+-- | A primitive matcher that looks up a value in a finite 'Map'. The+-- value must match exactly.+--+matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b)+matchExactly xs =+    \x -> case Map.lookup x m of+            Nothing -> matchZero+            Just ys -> ExactMatch 0 ys+  where+    m :: Ord a => Map a [b]+    m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]+-}++-- | A primitive matcher that looks up a value in a finite 'Map'. It checks+-- for an exact or inexact match. We get an inexact match if the match+-- is not exact, but the canonical forms match. It takes a canonicalisation+-- function for this purpose.+--+-- So for example if we used string case fold as the canonicalisation+-- function, then we would get case insensitive matching (but it will still+-- report an exact match when the case matches too).+matchInexactly+  :: (Ord a, Ord a')+  => (a -> a')+  -> [(a, b)]+  -> (a -> Match b)+matchInexactly 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+  where+    m = Map.fromListWith (++) [(k, [x]) | (k, x) <- xs]++    -- the map of canonicalised keys to groups of inexact matches+    m' = Map.mapKeysWith (++) cannonicalise m++------------------------------+-- Utils+--++caseFold :: String -> String+caseFold = lowercase++-- | Check that the given build targets are valid in the current context.+--+-- Also swizzle into a more convenient form.+checkBuildTargets+  :: Verbosity+  -> PackageDescription+  -> LocalBuildInfo+  -> [BuildTarget]+  -> IO [TargetInfo]+checkBuildTargets _ pkg_descr lbi [] =+  return (allTargetsInBuildOrder' pkg_descr lbi)+checkBuildTargets+  verbosity+  pkg_descr+  lbi@(LocalBuildInfo{componentEnabledSpec = enabledComps})+  targets = do+    let (enabled, disabled) =+          partitionEithers+            [ case componentDisabledReason enabledComps comp of+              Nothing -> Left target'+              Just reason -> Right (cname, reason)+            | target <- targets+            , let target'@(cname, _) = swizzleTarget target+            , let comp = getComponent pkg_descr cname+            ]++    case disabled of+      [] -> return ()+      ((cname, reason) : _) -> dieWithException verbosity $ CheckBuildTargets $ formatReason (showComponentName cname) reason++    for_ [(c, t) | (c, Just t) <- enabled] $ \(c, t) ->+      warn verbosity $+        "Ignoring '"+          ++ either prettyShow id t+          ++ ". The whole "+          ++ showComponentName c+          ++ " will be processed. (Support for "+          ++ "module and file targets has not been implemented yet.)"++    -- Pick out the actual CLBIs for each of these cnames+    enabled' <- for enabled $ \(cname, _) -> do+      case componentNameTargets' pkg_descr lbi cname of+        [] -> error "checkBuildTargets: nothing enabled"+        [target] -> return target+        _targets -> error "checkBuildTargets: multiple copies enabled"++    return enabled'+    where+      swizzleTarget (BuildTargetComponent c) = (c, Nothing)+      swizzleTarget (BuildTargetModule c m) = (c, Just (Left m))+      swizzleTarget (BuildTargetFile c f) = (c, Just (Right f))++      formatReason cn DisabledComponent =+        "Cannot process the "+          ++ cn+          ++ " because the component is marked "+          ++ "as disabled in the .cabal file."+      formatReason cn DisabledAllTests =+        "Cannot process the "+          ++ cn+          ++ " because test suites are not "+          ++ "enabled. Run configure with the flag --enable-tests"+      formatReason cn DisabledAllBenchmarks =+        "Cannot process the "+          ++ cn+          ++ " because benchmarks are not "+          ++ "enabled. Re-run configure with the flag --enable-benchmarks"+      formatReason cn (DisabledAllButOne cn') =+        "Cannot process the "+          ++ cn+          ++ " because this package was "+          ++ "configured only to build "+          ++ cn'+          ++ ". Re-run configure "+          ++ "with the argument "+          ++ cn
src/Distribution/Simple/BuildToolDepends.hs view
@@ -5,18 +5,44 @@ -- the functions contained to access those fields directly. module Distribution.Simple.BuildToolDepends where -import           Prelude ()-import           Distribution.Compat.Prelude+import Distribution.Compat.Prelude+import Prelude ()  import qualified Data.Map as Map -import           Distribution.Package-import           Distribution.PackageDescription+import Distribution.Package+import Distribution.PackageDescription --- | Desugar a "build-tools" entry into proper a executable dependency if+-- | Same as 'desugarBuildTool', but requires atomic information (package+-- name, executable names) instead of a whole 'PackageDescription'.+desugarBuildToolSimple+  :: PackageName+  -> [UnqualComponentName]+  -> LegacyExeDependency+  -> Maybe ExeDependency+desugarBuildToolSimple pname exeNames (LegacyExeDependency name reqVer)+  | foundLocal = Just $ ExeDependency pname toolName reqVer+  | otherwise = Map.lookup name allowMap+  where+    toolName = mkUnqualComponentName name+    foundLocal = toolName `elem` exeNames+    allowlist =+      [ "hscolour"+      , "haddock"+      , "happy"+      , "alex"+      , "hsc2hs"+      , "c2hs"+      , "cpphs"+      , "hspec-discover"+      ]+    allowMap = Map.fromList $ flip map allowlist $ \n ->+      (n, ExeDependency (mkPackageName n) (mkUnqualComponentName n) reqVer)++-- | Desugar a "build-tools" entry into a proper executable dependency if -- possible. ----- An entry can be so desguared in two cases:+-- An entry can be so desugared in two cases: -- -- 1. The name in build-tools matches a locally defined executable.  The --    executable dependency produced is on that exe in the current package.@@ -26,31 +52,25 @@ --    the same, but the hard-coding could just as well be per-key. -- -- The first cases matches first.-desugarBuildTool :: PackageDescription-                 -> LegacyExeDependency-                 -> Maybe ExeDependency+desugarBuildTool+  :: PackageDescription+  -> LegacyExeDependency+  -> Maybe ExeDependency desugarBuildTool pkg led =-  if foundLocal-  then Just $ ExeDependency (packageName pkg) toolName reqVer-  else Map.lookup name whiteMap-  where-    LegacyExeDependency name reqVer = led-    toolName = mkUnqualComponentName name-    foundLocal = toolName `elem` map exeName (executables pkg)-    whitelist = [ "hscolour", "haddock", "happy", "alex", "hsc2hs", "c2hs"-                , "cpphs", "greencard", "hspec-discover"-                ]-    whiteMap  = Map.fromList $ flip map whitelist $ \n ->-      (n, ExeDependency (mkPackageName n) (mkUnqualComponentName n) reqVer)+  desugarBuildToolSimple+    (packageName pkg)+    (map exeName $ executables pkg)+    led  -- | Get everything from "build-tool-depends", along with entries from -- "build-tools" that we know how to desugar. -- -- This should almost always be used instead of just accessing the -- `buildToolDepends` field directly.-getAllToolDependencies :: PackageDescription-                       -> BuildInfo-                       -> [ExeDependency]+getAllToolDependencies+  :: PackageDescription+  -> BuildInfo+  -> [ExeDependency] getAllToolDependencies pkg bi =   buildToolDepends bi ++ mapMaybe (desugarBuildTool pkg) (buildTools bi) @@ -78,14 +98,14 @@ isInternal :: PackageDescription -> ExeDependency -> Bool isInternal pkg (ExeDependency n _ _) = n == packageName pkg - -- | Get internal "build-tool-depends", along with internal "build-tools" -- -- This is a tiny function, but used in a number of places. The same -- restrictions that apply to `isInternal` also apply to this function.-getAllInternalToolDependencies :: PackageDescription-                               -> BuildInfo-                               -> [UnqualComponentName]+getAllInternalToolDependencies+  :: PackageDescription+  -> BuildInfo+  -> [UnqualComponentName] getAllInternalToolDependencies pkg bi =   [ toolname   | dep@(ExeDependency _ toolname _) <- getAllToolDependencies pkg bi
+ src/Distribution/Simple/BuildWay.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE LambdaCase #-}++module Distribution.Simple.BuildWay 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_"
src/Distribution/Simple/CCompiler.hs view
@@ -1,14 +1,4 @@ -------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.CCompiler--- Copyright   :  2011, Dan Knapp------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This simple package provides types and functions for interacting with--- C compilers.  Currently it's just a type enumerating extant C-like--- languages, which we call dialects.  {- Redistribution and use in source and binary forms, with or without@@ -39,85 +29,109 @@ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -module Distribution.Simple.CCompiler (-   CDialect(..),-   cSourceExtensions,-   cDialectFilenameExtension,-   filenameCDialect+-- |+-- Module      :  Distribution.Simple.CCompiler+-- Copyright   :  2011, Dan Knapp+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This simple package provides types and functions for interacting with+-- C compilers.  Currently it's just a type enumerating extant C-like+-- languages, which we call dialects.+module Distribution.Simple.CCompiler+  ( CDialect (..)+  , cSourceExtensions+  , cDialectFilenameExtension+  , filenameCDialect   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import System.FilePath-     ( takeExtension )-+  ( takeExtension+  )  -- | Represents a dialect of C.  The Monoid instance expresses backward --   compatibility, in the sense that 'mappend a b' is the least inclusive --   dialect which both 'a' and 'b' can be correctly interpreted as.-data CDialect = C-              | ObjectiveC-              | CPlusPlus-              | ObjectiveCPlusPlus-              deriving (Eq, Show)+data CDialect+  = C+  | ObjectiveC+  | CPlusPlus+  | ObjectiveCPlusPlus+  deriving (Eq, Show)  instance Monoid CDialect where   mempty = C   mappend = (<>)  instance Semigroup CDialect where-  C                  <> anything           = anything-  ObjectiveC         <> CPlusPlus          = ObjectiveCPlusPlus-  CPlusPlus          <> ObjectiveC         = ObjectiveCPlusPlus-  _                  <> ObjectiveCPlusPlus = ObjectiveCPlusPlus-  ObjectiveC         <> _                  = ObjectiveC-  CPlusPlus          <> _                  = CPlusPlus-  ObjectiveCPlusPlus <> _                  = ObjectiveCPlusPlus+  C <> anything = anything+  ObjectiveC <> CPlusPlus = ObjectiveCPlusPlus+  CPlusPlus <> ObjectiveC = ObjectiveCPlusPlus+  _ <> ObjectiveCPlusPlus = ObjectiveCPlusPlus+  ObjectiveC <> _ = ObjectiveC+  CPlusPlus <> _ = CPlusPlus+  ObjectiveCPlusPlus <> _ = ObjectiveCPlusPlus  -- | A list of all file extensions which are recognized as possibly containing --   some dialect of C code.  Note that this list is only for source files, --   not for header files. cSourceExtensions :: [String]-cSourceExtensions = ["c", "i", "ii", "m", "mi", "mm", "M", "mii", "cc", "cp",-                     "cxx", "cpp", "CPP", "c++", "C"]-+cSourceExtensions =+  [ "c"+  , "i"+  , "ii"+  , "m"+  , "mi"+  , "mm"+  , "M"+  , "mii"+  , "cc"+  , "cp"+  , "cxx"+  , "cpp"+  , "CPP"+  , "c++"+  , "C"+  ]  -- | Takes a dialect of C and whether code is intended to be passed through --   the preprocessor, and returns a filename extension for containing that --   code. cDialectFilenameExtension :: CDialect -> Bool -> String-cDialectFilenameExtension C True  = "c"+cDialectFilenameExtension C True = "c" cDialectFilenameExtension C False = "i"-cDialectFilenameExtension ObjectiveC True  = "m"+cDialectFilenameExtension ObjectiveC True = "m" cDialectFilenameExtension ObjectiveC False = "mi"-cDialectFilenameExtension CPlusPlus True   = "cpp"-cDialectFilenameExtension CPlusPlus False  = "ii"-cDialectFilenameExtension ObjectiveCPlusPlus True  = "mm"+cDialectFilenameExtension CPlusPlus True = "cpp"+cDialectFilenameExtension CPlusPlus False = "ii"+cDialectFilenameExtension ObjectiveCPlusPlus True = "mm" cDialectFilenameExtension ObjectiveCPlusPlus False = "mii" - -- | Infers from a filename's extension the dialect of C which it contains, --   and whether it is intended to be passed through the preprocessor. filenameCDialect :: String -> Maybe (CDialect, Bool) filenameCDialect filename = do   extension <- case takeExtension filename of-                 '.':ext -> Just ext-                 _       -> Nothing+    '.' : ext -> Just ext+    _ -> Nothing   case extension of-    "c"   -> return (C, True)-    "i"   -> return (C, False)-    "ii"  -> return (CPlusPlus, False)-    "m"   -> return (ObjectiveC, True)-    "mi"  -> return (ObjectiveC, False)-    "mm"  -> return (ObjectiveCPlusPlus, True)-    "M"   -> return (ObjectiveCPlusPlus, True)+    "c" -> return (C, True)+    "i" -> return (C, False)+    "ii" -> return (CPlusPlus, False)+    "m" -> return (ObjectiveC, True)+    "mi" -> return (ObjectiveC, False)+    "mm" -> return (ObjectiveCPlusPlus, True)+    "M" -> return (ObjectiveCPlusPlus, True)     "mii" -> return (ObjectiveCPlusPlus, False)-    "cc"  -> return (CPlusPlus, True)-    "cp"  -> return (CPlusPlus, True)+    "cc" -> return (CPlusPlus, True)+    "cp" -> return (CPlusPlus, True)     "cxx" -> return (CPlusPlus, True)     "cpp" -> return (CPlusPlus, True)     "CPP" -> return (CPlusPlus, True)     "c++" -> return (CPlusPlus, True)-    "C"   -> return (CPlusPlus, True)-    _     -> Nothing+    "C" -> return (CPlusPlus, True)+    _ -> Nothing
src/Distribution/Simple/Command.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Command -- Copyright   :  Duncan Coutts 2007@@ -18,88 +21,103 @@ -- run. It handles some common stuff automatically, like the @--help@ and -- command line completion flags. It is designed to allow other tools make -- derived commands. This feature is used heavily in @cabal-install@.--module Distribution.Simple.Command (--  -- * Command interface-  CommandUI(..),-  commandShowOptions,-  CommandParse(..),-  commandParseArgs,-  getNormalCommandDescriptions,-  helpCommandUI,--  -- ** Constructing commands-  ShowOrParseArgs(..),-  usageDefault,-  usageAlternatives,-  mkCommandUI,-  hiddenCommand,+module Distribution.Simple.Command+  ( -- * Command interface+    CommandUI (..)+  , commandShowOptions+  , CommandParse (..)+  , commandParseArgs+  , getNormalCommandDescriptions+  , helpCommandUI -  -- ** Associating actions with commands-  Command,-  commandAddAction,-  noExtraFlags,+    -- ** Constructing commands+  , ShowOrParseArgs (..)+  , usageDefault+  , usageAlternatives+  , mkCommandUI+  , hiddenCommand -  -- ** Building lists of commands-  CommandType(..),-  CommandSpec(..),-  commandFromSpec,+    -- ** Associating actions with commands+  , Command+  , commandAddAction+  , noExtraFlags -  -- ** Running commands-  commandsRun,+    -- ** Building lists of commands+  , CommandType (..)+  , CommandSpec (..)+  , commandFromSpec --- * Option Fields-  OptionField(..), Name,+    -- ** Running commands+  , commandsRun+  , commandsRunWithFallback+  , defaultCommandFallback --- ** Constructing Option Fields-  option, multiOption,+    -- * Option Fields+  , OptionField (..)+  , Name --- ** Liftings & Projections-  liftOption, liftOptionL,+    -- ** Constructing Option Fields+  , option+  , multiOption --- * Option Descriptions-  OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder,+    -- ** Liftings & Projections+  , liftOption+  , liftOptionL --- ** OptDescr 'smart' constructors-  MkOptDescr,-  reqArg, reqArg', optArg, optArg', noArg,-  boolOpt, boolOpt', choiceOpt, choiceOptFromEnum+    -- * Option Descriptions+  , OptDescr (..)+  , fmapOptDescr+  , Description+  , SFlags+  , LFlags+  , OptFlags+  , ArgPlaceHolder +    -- ** OptDescr 'smart' constructors+  , MkOptDescr+  , reqArg+  , reqArg'+  , optArg+  , optArg'+  , optArgDef'+  , noArg+  , boolOpt+  , boolOpt'+  , choiceOpt+  , choiceOptFromEnum   ) where -import Prelude () import Distribution.Compat.Prelude hiding (get)+import Prelude ()  import qualified Data.Array as Array import qualified Data.List as List+import Distribution.Compat.Lens (ALens', (#~), (^#)) import qualified Distribution.GetOpt as GetOpt import Distribution.ReadE import Distribution.Simple.Utils-import Distribution.Compat.Lens (ALens', (^#), (#~)) --data CommandUI flags = CommandUI {-    -- | The name of the command as it would be entered on the command line.-    -- For example @\"build\"@.-    commandName        :: String,-    -- | A short, one line description of the command to use in help texts.-    commandSynopsis :: String,-    -- | A function that maps a program name to a usage summary for this-    -- command.-    commandUsage    :: String -> String,-    -- | Additional explanation of the command to use in help texts.-    commandDescription :: Maybe (String -> String),-    -- | Post-Usage notes and examples in help texts-    commandNotes :: Maybe (String -> String),-    -- | Initial \/ empty flags-    commandDefaultFlags :: flags,-    -- | All the Option fields for this command-    commandOptions     :: ShowOrParseArgs -> [OptionField flags]+data CommandUI flags = CommandUI+  { commandName :: String+  -- ^ The name of the command as it would be entered on the command line.+  -- For example @\"build\"@.+  , commandSynopsis :: String+  -- ^ A short, one line description of the command to use in help texts.+  , commandUsage :: String -> String+  -- ^ A function that maps a program name to a usage summary for this+  -- command.+  , commandDescription :: Maybe (String -> String)+  -- ^ Additional explanation of the command to use in help texts.+  , commandNotes :: Maybe (String -> String)+  -- ^ Post-Usage notes and examples in help texts+  , commandDefaultFlags :: flags+  -- ^ Initial \/ empty flags+  , commandOptions :: ShowOrParseArgs -> [OptionField flags]+  -- ^ All the Option fields for this command   }  data ShowOrParseArgs = ShowArgs | ParseArgs-type Name        = String+type Name = String type Description = String  -- | We usually have a data type for storing configuration values, where@@ -107,481 +125,670 @@ --   the value either via command line flags or a configuration file. --   An individual OptionField models such a field, and we usually --   build a list of options associated to a configuration data type.-data OptionField a = OptionField {-  optionName        :: Name,-  optionDescr       :: [OptDescr a] }+data OptionField a = OptionField+  { optionName :: Name+  , optionDescr :: [OptDescr a]+  }  -- | An OptionField takes one or more OptDescrs, describing the command line -- interface for the field.-data OptDescr a  = ReqArg Description OptFlags ArgPlaceHolder-                   (ReadE (a->a)) (a -> [String])--                 | OptArg Description OptFlags ArgPlaceHolder-                   (ReadE (a->a)) (a->a)  (a -> [Maybe String])--                 | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)]+data OptDescr a+  = ReqArg+      Description+      OptFlags+      ArgPlaceHolder+      (ReadE (a -> a))+      (a -> [String])+  | OptArg+      Description+      OptFlags+      ArgPlaceHolder+      (ReadE (a -> a))+      (String, a -> a)+      (a -> [Maybe String])+  | ChoiceOpt [(Description, OptFlags, a -> a, a -> Bool)]+  | BoolOpt+      Description+      OptFlags {-True-}+      OptFlags {-False-}+      (Bool -> a -> a)+      (a -> Maybe Bool) -                 | BoolOpt Description OptFlags{-True-} OptFlags{-False-}-                   (Bool -> a -> a) (a-> Maybe Bool)+fmapOptDescr :: forall a b. (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b+fmapOptDescr x u = \case+  ReqArg d o p upd get -> ReqArg d o p (fmap m upd) (get . x)+  OptArg d o p upd (str, g) get -> OptArg d o p (fmap m upd) (str, m g) (get . x)+  ChoiceOpt opts -> ChoiceOpt $ fmap (\(d, o, upd, get) -> (d, o, m upd, get . x)) opts+  BoolOpt d true false upd get -> BoolOpt d true false (\b -> m $ upd b) (get . x)+  where+    m :: (a -> a) -> (b -> b)+    m upd_a b = u (upd_a $ x b) b  -- | Short command line option strings-type SFlags   = [Char]+type SFlags = [Char]+ -- | Long command line option strings-type LFlags   = [String]-type OptFlags = (SFlags,LFlags)-type ArgPlaceHolder = String+type LFlags = [String] +type OptFlags = (SFlags, LFlags)+type ArgPlaceHolder = String  -- | Create an option taking a single OptDescr. --   No explicit Name is given for the Option, the name is the first LFlag given.-option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a-          -> OptionField a-option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set]-option _ _ _ _ _ _ = error $ "Distribution.command.option: "-                     ++ "An OptionField must have at least one LFlag"+--+-- Example: @'option' sf lf d get set@+-- * @sf@: Short option name, for example: @[\'d\']@. No hyphen permitted.+-- * @lf@: Long option name, for example: @["debug"]@. No hyphens permitted.+-- * @d@: Description of the option, shown to the user in help messages.+-- * @get@: Get the current value of the flag.+-- * @set@: Set the value of the flag. Gets the current value of the flag as a+--          parameter.+option+  :: SFlags+  -> LFlags+  -> Description+  -> get+  -> set+  -> MkOptDescr get set a+  -> OptionField a+option sf lf@(n : _) d get set arg = OptionField n [arg sf lf d get set]+option _ _ _ _ _ _ =+  error $+    "Distribution.command.option: "+      ++ "An OptionField must have at least one LFlag"  -- | Create an option taking several OptDescrs. --   You will have to give the flags and description individually to the --   OptDescr constructor.-multiOption :: Name -> get -> set-            -> [get -> set -> OptDescr a]  -- ^MkOptDescr constructors partially-                                           -- applied to flags and description.-            -> OptionField a+multiOption+  :: Name+  -> get+  -> set+  -> [get -> set -> OptDescr a]+  -- ^ MkOptDescr constructors partially+  --  applied to flags and description.+  -> OptionField a multiOption n get set args = OptionField n [arg get set | arg <- args] -type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set-                            -> OptDescr a+type MkOptDescr get set a =+  SFlags+  -> LFlags+  -> Description+  -> get+  -> set+  -> OptDescr a  -- | Create a string-valued command line interface.-reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String])-                   -> MkOptDescr (a -> b) (b -> a -> a) a+-- Usually called in the context of 'option' or 'multiOption'.+--+-- Example: @'reqArg' ad mkflag showflag@+--+-- * @ad@: Placeholder shown to the user, e.g. @"FILES"@ if files are expected+--         parameters.+-- * @mkflag@: How to parse the argument into the option.+-- * @showflag@: If parsing goes wrong, display a useful error message to+--               the user.+reqArg+  :: Monoid b+  => ArgPlaceHolder+  -> ReadE b+  -> (b -> [String])+  -> MkOptDescr (a -> b) (b -> a -> a) a reqArg ad mkflag showflag sf lf d get set =-  ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag)-  (showflag . get)+  ReqArg+    d+    (sf, lf)+    ad+    (fmap (\a b -> set (get b `mappend` a) b) mkflag)+    (showflag . get)  -- | Create a string-valued command line interface with a default value.-optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String])-                   -> MkOptDescr (a -> b) (b -> a -> a) a-optArg ad mkflag def showflag sf lf d get set  =-  OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag)-               (\b ->          set (get b `mappend` def) b)-               (showflag . get)+optArg+  :: Monoid b+  => ArgPlaceHolder+  -> ReadE b+  -> (String, b)+  -> (b -> [Maybe String])+  -> MkOptDescr (a -> b) (b -> a -> a) a+optArg ad mkflag (dv, mkDef) showflag sf lf d get set =+  OptArg+    d+    (sf, lf)+    ad+    (fmap (\a b -> set (get b `mappend` a) b) mkflag)+    (dv, \b -> set (get b `mappend` mkDef) b)+    (showflag . get)  -- | (String -> a) variant of "reqArg"-reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String])-                    -> MkOptDescr (a -> b) (b -> a -> a) a+reqArg'+  :: Monoid b+  => ArgPlaceHolder+  -> (String -> b)+  -> (b -> [String])+  -> MkOptDescr (a -> b) (b -> a -> a) a reqArg' ad mkflag showflag =-    reqArg ad (succeedReadE mkflag) showflag+  reqArg ad (succeedReadE mkflag) showflag  -- | (String -> a) variant of "optArg"-optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b)-           -> (b -> [Maybe String])-           -> MkOptDescr (a -> b) (b -> a -> a) a+optArg'+  :: Monoid b+  => ArgPlaceHolder+  -> (Maybe String -> b)+  -> (b -> [Maybe String])+  -> MkOptDescr (a -> b) (b -> a -> a) a optArg' ad mkflag showflag =-    optArg ad (succeedReadE (mkflag . Just)) def showflag-      where def = mkflag Nothing+  optArg ad (succeedReadE (mkflag . Just)) ("", mkflag Nothing) showflag -noArg :: (Eq b) => b -> MkOptDescr (a -> b) (b -> a -> a) a-noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d+optArgDef'+  :: Monoid b+  => ArgPlaceHolder+  -> (String, Maybe String -> b)+  -> (b -> [Maybe String])+  -> MkOptDescr (a -> b) (b -> a -> a) a+optArgDef' ad (dv, mkflag) showflag =+  optArg ad (succeedReadE (mkflag . Just)) (dv, mkflag Nothing) showflag -boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags-           -> MkOptDescr (a -> b) (b -> a -> a) a-boolOpt g s sfT sfF _sf _lf@(n:_) d get set =-    BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get)-boolOpt _ _ _ _ _ _ _ _ _ = error-                            "Distribution.Simple.Setup.boolOpt: unreachable"+noArg :: Eq b => b -> MkOptDescr (a -> b) (b -> a -> a) a+noArg flag sf lf d = choiceOpt [(flag, (sf, lf), d)] sf lf d -boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags-            -> MkOptDescr (a -> b) (b -> a -> a) a-boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get)+boolOpt+  :: (b -> Maybe Bool)+  -> (Bool -> b)+  -> SFlags+  -> SFlags+  -> MkOptDescr (a -> b) (b -> a -> a) a+boolOpt g s sfT sfF _sf _lf@(n : _) d get set =+  BoolOpt d (sfT, ["enable-" ++ n]) (sfF, ["disable-" ++ n]) (set . s) (g . get)+boolOpt _ _ _ _ _ _ _ _ _ =+  error+    "Distribution.Simple.Setup.boolOpt: unreachable" +boolOpt'+  :: (b -> Maybe Bool)+  -> (Bool -> b)+  -> OptFlags+  -> OptFlags+  -> MkOptDescr (a -> b) (b -> a -> a) a+boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set . s) (g . get)+ -- | create a Choice option-choiceOpt :: Eq b => [(b,OptFlags,Description)]-             -> MkOptDescr (a -> b) (b -> a -> a) a-choiceOpt aa_ff _sf _lf _d get set  = ChoiceOpt alts-    where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff]+choiceOpt+  :: Eq b+  => [(b, OptFlags, Description)]+  -> MkOptDescr (a -> b) (b -> a -> a) a+choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts+  where+    alts = [(d, flags, set alt, (== alt) . get) | (alt, flags, d) <- aa_ff]  -- | create a Choice option out of an enumeration type. --   As long flags, the Show output is used. As short flags, the first character --   which does not conflict with a previous one is used.-choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) =>-                     MkOptDescr (a -> b) (b -> a -> a) a+choiceOptFromEnum+  :: (Bounded b, Enum b, Show b, Eq b)+  => MkOptDescr (a -> b) (b -> a -> a) a choiceOptFromEnum _sf _lf d get =-  choiceOpt [ (x, (sf, [map toLower $ show x]), d')-            | (x, sf) <- sflags'-            , let d' = d ++ show x]-  _sf _lf d get-  where sflags' = foldl f [] [firstOne..]-        f prev x = let prevflags = concatMap snd prev in-                       prev ++ take 1 [(x, [toLower sf])-                                      | sf <- show x, isAlpha sf-                                      , toLower sf `notElem` prevflags]-        firstOne = minBound `asTypeOf` get undefined+  choiceOpt+    [ (x, (sf, [map toLower $ show x]), d')+    | (x, sf) <- sflags'+    , let d' = d ++ show x+    ]+    _sf+    _lf+    d+    get+  where+    sflags' = foldl f [] [firstOne ..]+    f prev x =+      let prevflags = concatMap snd prev+       in prev+            ++ take+              1+              [ (x, [toLower sf])+              | sf <- show x+              , isAlpha sf+              , toLower sf `notElem` prevflags+              ]+    firstOne = minBound `asTypeOf` get undefined -commandGetOpts :: ShowOrParseArgs -> CommandUI flags-                  -> [GetOpt.OptDescr (flags -> flags)]+commandGetOpts+  :: ShowOrParseArgs+  -> CommandUI flags+  -> [GetOpt.OptDescr (flags -> flags)] commandGetOpts showOrParse command =-    concatMap viewAsGetOpt (commandOptions command showOrParse)+  concatMap viewAsGetOpt (commandOptions command showOrParse) -viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)]+viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a -> a)] viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa   where-    optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) =-         [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d]-             where set' = readEOrFail set-    optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) =-         [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d]-             where set' Nothing    = def-                   set' (Just txt) = readEOrFail set txt+    optDescrToGetOpt (ReqArg d (cs, ss) arg_desc set _) =+      [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d]+    optDescrToGetOpt (OptArg d (cs, ss) arg_desc set (dv, def) _) =+      [GetOpt.Option cs ss (GetOpt.OptArg dv set' arg_desc) d]+      where+        set' Nothing = Right def+        set' (Just txt) = runReadE set txt     optDescrToGetOpt (ChoiceOpt alts) =-         [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ]-    optDescrToGetOpt (BoolOpt d (sfT, lfT) ([],  [])  set _) =-         [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True))  d ]-    optDescrToGetOpt (BoolOpt d ([],  [])  (sfF, lfF) set _) =-         [ GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d ]-    optDescrToGetOpt (BoolOpt d (sfT,lfT)  (sfF, lfF) set _) =-         [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True))  ("Enable " ++ d)-         , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ]+      [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d, (sf, lf), set, _) <- alts]+    optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) =+      [GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d]+    optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) =+      [GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d]+    optDescrToGetOpt (BoolOpt d (sfT, lfT) (sfF, lfF) set _) =+      [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d)+      , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d)+      ]  getCurrentChoice :: OptDescr a -> a -> [String] getCurrentChoice (ChoiceOpt alts) a =-    [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a]-+  [lf | (_, (_sf, lf : _), _, currentChoice) <- alts, currentChoice a] getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" - liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b liftOption get' set' opt =-  opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt}+  opt{optionDescr = liftOptDescr get' set' `map` optionDescr opt}  -- | @since 3.4.0.0 liftOptionL :: ALens' b a -> OptionField a -> OptionField b liftOptionL l = liftOption (^# l) (l #~) - liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b liftOptDescr get' set' (ChoiceOpt opts) =-    ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get'))-              | (d, ff, set, get) <- opts]--liftOptDescr get' set' (OptArg d ff ad set def get) =-    OptArg d ff ad (liftSet get' set' `fmap` set)-    (liftSet get' set' def) (get . get')-+  ChoiceOpt+    [ (d, ff, liftSet get' set' set, (get . get'))+    | (d, ff, set, get) <- opts+    ]+liftOptDescr get' set' (OptArg d ff ad set (dv, mkDef) get) =+  OptArg+    d+    ff+    ad+    (liftSet get' set' `fmap` set)+    (dv, liftSet get' set' mkDef)+    (get . get') liftOptDescr get' set' (ReqArg d ff ad set get) =-    ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get')-+  ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') liftOptDescr get' set' (BoolOpt d ffT ffF set get) =-    BoolOpt d ffT ffF (liftSet get' set' . set) (get . get')+  BoolOpt d ffT ffF (liftSet get' set' . set) (get . get')  liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b liftSet get' set' set x = set' (set $ get' x) x  -- | Show flags in the standard long option command line format commandShowOptions :: CommandUI flags -> flags -> [String]-commandShowOptions command v = concat-  [ showOptDescr v  od | o <- commandOptions command ParseArgs-                       , od <- optionDescr o]+commandShowOptions command v =+  concat+    [ showOptDescr v od | o <- commandOptions command ParseArgs, od <- optionDescr o+    ]   where-    maybePrefix []       = []-    maybePrefix (lOpt:_) = ["--" ++ lOpt]+    maybePrefix [] = []+    maybePrefix (lOpt : _) = ["--" ++ lOpt]      showOptDescr :: a -> OptDescr a -> [String]-    showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled)-      = case enabled x of-          Nothing -> []-          Just True  -> maybePrefix lfTs-          Just False -> maybePrefix lfFs-    showOptDescr x c@ChoiceOpt{}-      = ["--" ++ val | val <- getCurrentChoice c x]-    showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag)-      = [ "--"++lf++"="++flag-        | flag <- showflag x ]-    showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag)-      = [ case flag of-            Just s  -> "--"++lf++"="++s-            Nothing -> "--"++lf-        | flag <- showflag x ]-    showOptDescr _ _-      = error "Distribution.Simple.Command.showOptDescr: unreachable"-+    showOptDescr x (BoolOpt _ (_, lfTs) (_, lfFs) _ enabled) =+      case enabled x of+        Nothing -> []+        Just True -> maybePrefix lfTs+        Just False -> maybePrefix lfFs+    showOptDescr x c@ChoiceOpt{} =+      ["--" ++ val | val <- getCurrentChoice c x]+    showOptDescr x (ReqArg _ (_ssff, lf : _) _ _ showflag) =+      [ "--" ++ lf ++ "=" ++ flag+      | flag <- showflag x+      ]+    showOptDescr x (OptArg _ (_ssff, lf : _) _ _ _ showflag) =+      [ case flag of+        Just s -> "--" ++ lf ++ "=" ++ s+        Nothing -> "--" ++ lf+      | flag <- showflag x+      ]+    showOptDescr _ _ =+      error "Distribution.Simple.Command.showOptDescr: unreachable"  commandListOptions :: CommandUI flags -> [String] commandListOptions command =   concatMap listOption $     addCommonFlags ShowArgs $ -- This is a slight hack, we don't want-                              -- "--list-options" showing up in the-                              -- list options output, so use ShowArgs+    -- "--list-options" showing up in the+    -- list options output, so use ShowArgs       commandGetOpts ShowArgs command   where     listOption (GetOpt.Option shortNames longNames _ _) =-         [ "-"  ++ [name] | name <- shortNames ]-      ++ [ "--" ++  name  | name <- longNames ]+      ["-" ++ [name] | name <- shortNames]+        ++ ["--" ++ name | name <- longNames]  -- | The help text for this command with descriptions of all the options. commandHelp :: CommandUI flags -> String -> String commandHelp command pname =-    commandSynopsis command- ++ "\n\n"- ++ commandUsage command pname- ++ ( case commandDescription command of-        Nothing   -> ""-        Just desc -> '\n': desc pname)- ++ "\n"- ++ ( if cname == ""-        then "Global flags:"-        else "Flags for " ++ cname ++ ":" )- ++ ( GetOpt.usageInfo ""-    . addCommonFlags ShowArgs-    $ commandGetOpts ShowArgs command )- ++ ( case commandNotes command of-        Nothing   -> ""-        Just notes -> '\n': notes pname)-  where cname = commandName command+  commandSynopsis command+    ++ "\n\n"+    ++ commandUsage command pname+    ++ ( case commandDescription command of+          Nothing -> ""+          Just desc -> '\n' : desc pname+       )+    ++ "\n"+    ++ ( if cname == ""+          then "Global flags:"+          else "Flags for " ++ cname ++ ":"+       )+    ++ ( GetOpt.usageInfo ""+          . addCommonFlags ShowArgs+          $ commandGetOpts ShowArgs command+       )+    ++ ( case commandNotes command of+          Nothing -> ""+          Just notes -> '\n' : notes pname+       )+  where+    cname = commandName command  -- | Default "usage" documentation text for commands. usageDefault :: String -> String -> String usageDefault name pname =-     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"-  ++ "Flags for " ++ name ++ ":"+  "Usage: "+    ++ pname+    ++ " "+    ++ name+    ++ " [FLAGS]\n\n"+    ++ "Flags for "+    ++ name+    ++ ":"  -- | Create "usage" documentation from a list of parameter --   configurations. usageAlternatives :: String -> [String] -> String -> String-usageAlternatives name strs pname = unlines-  [ start ++ pname ++ " " ++ name ++ " " ++ s-  | let starts = "Usage: " : repeat "   or: "-  , (start, s) <- zip starts strs-  ]+usageAlternatives name strs pname =+  unlines+    [ start ++ pname ++ " " ++ name ++ " " ++ s+    | let starts = "Usage: " : repeat "   or: "+    , (start, s) <- zip starts strs+    ]  -- | Make a Command from standard 'GetOpt' options.-mkCommandUI :: String          -- ^ name-            -> String          -- ^ synopsis-            -> [String]        -- ^ usage alternatives-            -> flags           -- ^ initial\/empty flags-            -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options-            -> CommandUI flags-mkCommandUI name synopsis usages flags options = CommandUI-  { commandName         = name-  , commandSynopsis     = synopsis-  , commandDescription  = Nothing-  , commandNotes        = Nothing-  , commandUsage        = usageAlternatives name usages-  , commandDefaultFlags = flags-  , commandOptions      = options-  }+mkCommandUI+  :: String+  -- ^ name+  -> String+  -- ^ synopsis+  -> [String]+  -- ^ usage alternatives+  -> flags+  -- ^ initial\/empty flags+  -> (ShowOrParseArgs -> [OptionField flags])+  -- ^ options+  -> CommandUI flags+mkCommandUI name synopsis usages flags options =+  CommandUI+    { commandName = name+    , commandSynopsis = synopsis+    , commandDescription = Nothing+    , commandNotes = Nothing+    , commandUsage = usageAlternatives name usages+    , commandDefaultFlags = flags+    , commandOptions = options+    }  -- | Common flags that apply to every command data CommonFlag = HelpFlag | ListOptionsFlag  commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] commonFlags showOrParseArgs = case showOrParseArgs of-  ShowArgs  -> [help]+  ShowArgs -> [help]   ParseArgs -> [help, list]- where-    help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag)-             "Show this help text"+  where+    help =+      GetOpt.Option+        helpShortFlags+        ["help"]+        (GetOpt.NoArg HelpFlag)+        "Show this help text"     helpShortFlags = case showOrParseArgs of-      ShowArgs  -> ['h']+      ShowArgs -> ['h']       ParseArgs -> ['h', '?']-    list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag)-             "Print a list of command line flags"+    list =+      GetOpt.Option+        []+        ["list-options"]+        (GetOpt.NoArg ListOptionsFlag)+        "Print a list of command line flags" -addCommonFlags :: ShowOrParseArgs-               -> [GetOpt.OptDescr a]-               -> [GetOpt.OptDescr (Either CommonFlag a)]+addCommonFlags+  :: ShowOrParseArgs+  -> [GetOpt.OptDescr a]+  -> [GetOpt.OptDescr (Either CommonFlag a)] addCommonFlags showOrParseArgs options =-     map (fmapOptDesc Left)  (commonFlags showOrParseArgs)-  ++ map (fmapOptDesc Right) options-  where fmapOptDesc f (GetOpt.Option s l d m) =-                       GetOpt.Option s l (fmapArgDesc f d) m-        fmapArgDesc f (GetOpt.NoArg a)    = GetOpt.NoArg (f a)-        fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d-        fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d+  map (fmap Left) (commonFlags showOrParseArgs)+    ++ map (fmap Right) options  -- | Parse a bunch of command line arguments----commandParseArgs :: CommandUI flags-                 -> Bool      -- ^ Is the command a global or subcommand?-                 -> [String]-                 -> CommandParse (flags -> flags, [String])+commandParseArgs+  :: CommandUI flags+  -> Bool+  -- ^ Is the command a global or subcommand?+  -> [String]+  -> CommandParse (flags -> flags, [String]) commandParseArgs command global args =-  let options = addCommonFlags ParseArgs-              $ commandGetOpts ParseArgs command-      order | global    = GetOpt.RequireOrder-            | otherwise = GetOpt.Permute-  in case GetOpt.getOpt' order options args of-    (flags, _, _,  _)-      | any listFlag flags -> CommandList (commandListOptions command)-      | any helpFlag flags -> CommandHelp (commandHelp command)-      where listFlag (Left ListOptionsFlag) = True; listFlag _ = False-            helpFlag (Left HelpFlag)        = True; helpFlag _ = False-    (flags, opts, opts', [])-      | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts')-      | otherwise            -> CommandErrors (unrecognised opts')-    (_, _, _, errs)          -> CommandErrors errs--  where -- Note: It is crucial to use reverse function composition here or to-        -- reverse the flags here as we want to process the flags left to right-        -- but data flow in function composition is right to left.-        accum flags = foldr (flip (.)) id [ f | Right f <- flags ]-        unrecognised opts = [ "unrecognized "-                              ++ "'" ++ (commandName command) ++ "'"-                              ++ " option `" ++ opt ++ "'\n"-                            | opt <- opts ]-        -- For unrecognised global flags we put them in the position just after-        -- the command, if there is one. This gives us a chance to parse them-        -- as sub-command rather than global flags.-        mix []     ys = ys-        mix (x:xs) ys = x:ys++xs+  let options =+        addCommonFlags ParseArgs $+          commandGetOpts ParseArgs command+      order+        | global = GetOpt.RequireOrder+        | otherwise = GetOpt.Permute+   in case GetOpt.getOpt' order options args of+        (flags, _, _, _)+          | any listFlag flags -> CommandList (commandListOptions command)+          | any helpFlag flags -> CommandHelp (commandHelp command)+          where+            listFlag (Left ListOptionsFlag) = True; listFlag _ = False+            helpFlag (Left HelpFlag) = True; helpFlag _ = False+        (flags, opts, opts', [])+          | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts')+          | otherwise -> CommandErrors (unrecognised opts')+        (_, _, _, errs) -> CommandErrors errs+  where+    -- Note: It is crucial to use reverse function composition here or to+    -- reverse the flags here as we want to process the flags left to right+    -- but data flow in function composition is right to left.+    accum flags = foldr (flip (.)) id [f | Right f <- flags]+    unrecognised opts =+      [ "unrecognized "+        ++ "'"+        ++ (commandName command)+        ++ "'"+        ++ " option `"+        ++ opt+        ++ "'\n"+      | opt <- opts+      ]+    -- For unrecognised global flags we put them in the position just after+    -- the command, if there is one. This gives us a chance to parse them+    -- as sub-command rather than global flags.+    mix [] ys = ys+    mix (x : xs) ys = x : ys ++ xs -data CommandParse flags = CommandHelp (String -> String)-                        | CommandList [String]-                        | CommandErrors [String]-                        | CommandReadyToGo flags+data CommandParse flags+  = CommandHelp (String -> String)+  | CommandList [String]+  | CommandErrors [String]+  | CommandReadyToGo flags instance Functor CommandParse where-  fmap _ (CommandHelp help)       = CommandHelp help-  fmap _ (CommandList opts)       = CommandList opts-  fmap _ (CommandErrors errs)     = CommandErrors errs+  fmap _ (CommandHelp help) = CommandHelp help+  fmap _ (CommandList opts) = CommandList opts+  fmap _ (CommandErrors errs) = CommandErrors errs   fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) - data CommandType = NormalCommand | HiddenCommand-data Command action =-  Command String String ([String] -> CommandParse action) CommandType+data Command action+  = Command String String ([String] -> CommandParse action) CommandType  -- | Mark command as hidden. Hidden commands don't show up in the 'progname -- help' or 'progname --help' output. 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-                 -> (flags -> [String] -> action)-                 -> Command action+commandAddAction+  :: CommandUI flags+  -> (flags -> [String] -> action)+  -> Command action commandAddAction command action =-  Command (commandName command)-          (commandSynopsis command)-          (fmap (uncurry applyDefaultArgs) . commandParseArgs command False)-          NormalCommand+  Command+    (commandName command)+    (commandSynopsis command)+    (fmap (uncurry applyDefaultArgs) . commandParseArgs command False)+    NormalCommand+  where+    applyDefaultArgs mkflags args =+      let flags = mkflags (commandDefaultFlags command)+       in action flags args -  where applyDefaultArgs mkflags args =-          let flags = mkflags (commandDefaultFlags command)-           in action flags args+-- Print suggested command if edit distance is < 5+badCommand :: [Command action] -> String -> CommandParse a+badCommand commands' cname =+  case eDists of+    [] -> CommandErrors [unErr]+    (s : _) ->+      CommandErrors+        [ unErr+        , "Maybe you meant `" ++ s ++ "`?\n"+        ]+  where+    eDists =+      map fst . List.sortBy (comparing snd) $+        [ (cname', dist)+        | -- Note that this is not commandNames, so close suggestions will show+        -- hidden commands+        (Command cname' _ _ _) <- commands'+        , let dist = editDistance cname' cname+        , dist < 5+        ]+    unErr = "unrecognised command: " ++ cname ++ " (try --help)" -commandsRun :: CommandUI a-            -> [Command action]-            -> [String]-            -> CommandParse (a, CommandParse action)+commandsRun+  :: CommandUI a+  -> [Command action]+  -> [String]+  -> IO (CommandParse (a, CommandParse action)) commandsRun globalCommand commands args =-  case commandParseArgs globalCommand True args of-    CommandHelp      help          -> CommandHelp help-    CommandList      opts          -> CommandList (opts ++ commandNames)-    CommandErrors    errs          -> CommandErrors errs-    CommandReadyToGo (mkflags, args') -> case args' of-      ("help":cmdArgs) -> handleHelpCommand cmdArgs-      (name:cmdArgs)   -> case lookupCommand name of-        [Command _ _ action _]-          -> CommandReadyToGo (flags, action cmdArgs)-        _ -> CommandReadyToGo (flags, badCommand name)-      []               -> CommandReadyToGo (flags, noCommand)-     where flags = mkflags (commandDefaultFlags globalCommand)+  commandsRunWithFallback globalCommand commands defaultCommandFallback args - where-    lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands'-                                , cname' == cname ]-    noCommand        = CommandErrors ["no command given (try --help)\n"]+defaultCommandFallback+  :: [Command action]+  -> String+  -> [String]+  -> IO (CommandParse action)+defaultCommandFallback commands' name _cmdArgs = pure $ badCommand commands' name -    -- Print suggested command if edit distance is < 5-    badCommand :: String -> CommandParse a-    badCommand cname =-      case eDists of-        [] -> CommandErrors [unErr]-        (s:_) -> CommandErrors [ unErr-                                , "Maybe you meant `" ++ s ++ "`?\n"]+commandsRunWithFallback+  :: CommandUI a+  -> [Command action]+  -> ([Command action] -> String -> [String] -> IO (CommandParse action))+  -> [String]+  -> IO (CommandParse (a, CommandParse action))+commandsRunWithFallback globalCommand commands defaultCommand args =+  case commandParseArgs globalCommand True args of+    CommandHelp help -> pure $ CommandHelp help+    CommandList opts -> pure $ CommandList (opts ++ commandNames)+    CommandErrors errs -> pure $ CommandErrors errs+    CommandReadyToGo (mkflags, args') -> case args' of+      ("help" : cmdArgs) -> handleHelpCommand flags cmdArgs+      (name : cmdArgs) -> case lookupCommand name of+        [Command _ _ action _] ->+          pure $ CommandReadyToGo (flags, action cmdArgs)+        _ -> do+          final_cmd <- defaultCommand commands' name cmdArgs+          return $ CommandReadyToGo (flags, final_cmd)+      [] -> pure $ CommandReadyToGo (flags, noCommand)       where-        eDists = map fst . List.sortBy (comparing snd) $-                   [ (cname', dist)-                   | (Command cname' _ _ _) <- commands'-                   , let dist = editDistance cname' cname-                   , dist < 5 ]-        unErr = "unrecognised command: " ++ cname ++ " (try --help)"+        flags = mkflags (commandDefaultFlags globalCommand)+  where+    lookupCommand cname =+      [ cmd | cmd@(Command cname' _ _ _) <- commands', cname' == cname+      ] -    commands'      = commands ++ [commandAddAction helpCommandUI undefined]-    commandNames   = [ name | (Command name _ _ NormalCommand) <- commands' ]+    noCommand = CommandErrors ["no command given (try --help)\n"] +    commands' = commands ++ [commandAddAction helpCommandUI undefined]+    commandNames = [name | (Command name _ _ NormalCommand) <- commands']+     -- A bit of a hack: support "prog help" as a synonym of "prog --help"     -- furthermore, support "prog help command" as "prog command --help"-    handleHelpCommand cmdArgs =+    handleHelpCommand flags cmdArgs =       case commandParseArgs helpCommandUI True cmdArgs of-        CommandHelp      help    -> CommandHelp help-        CommandList      list    -> CommandList (list ++ commandNames)-        CommandErrors    _       -> CommandHelp globalHelp-        CommandReadyToGo (_,[])  -> CommandHelp globalHelp-        CommandReadyToGo (_,(name:cmdArgs')) ->+        CommandHelp help -> pure $ CommandHelp help+        CommandList list -> pure $ CommandList (list ++ commandNames)+        CommandErrors _ -> pure $ CommandHelp globalHelp+        CommandReadyToGo (_, []) -> pure $ CommandHelp globalHelp+        CommandReadyToGo (_, (name : cmdArgs')) ->           case lookupCommand name of             [Command _ _ action _] ->-              case action ("--help":cmdArgs') of-                CommandHelp help -> CommandHelp help-                CommandList _    -> CommandList []-                _                -> CommandHelp globalHelp-            _                    -> badCommand name--     where globalHelp = commandHelp globalCommand+              case action ("--help" : cmdArgs') of+                CommandHelp help -> pure $ CommandHelp help+                CommandList _ -> pure $ CommandList []+                _ -> pure $ CommandHelp globalHelp+            _ -> do+              fall_back <- defaultCommand commands' name ("--help" : cmdArgs')+              return $ CommandReadyToGo (flags, fall_back)+      where+        globalHelp = commandHelp globalCommand  -- Levenshtein distance, from https://wiki.haskell.org/Edit_distance -- (Author: JeanPhilippeBernardy, Simple Permissive Licence) editDistance :: Eq a => [a] -> [a] -> Int-editDistance xs ys = table Array.! (m,n)+editDistance xs ys = table Array.! (m, n)   where-    (m,n) = (length xs, length ys)-    x     = Array.array (1,m) (zip [1..] xs)-    y     = Array.array (1,n) (zip [1..] ys)+    (m, n) = (length xs, length ys)+    x = Array.array (1, m) (zip [1 ..] xs)+    y = Array.array (1, n) (zip [1 ..] ys) -    table :: Array.Array (Int,Int) Int+    table :: Array.Array (Int, Int) Int     table = Array.array bnds [(ij, dist ij) | ij <- Array.range bnds]-    bnds  = ((0,0),(m,n))+    bnds = ((0, 0), (m, n)) -    dist (0,j) = j-    dist (i,0) = i-    dist (i,j) = minimum-      [ table Array.! (i-1,j) + 1-      , table Array.! (i,j-1) + 1-      , if x Array.! i == y Array.! j-          then table Array.! (i-1,j-1)-          else 1 + table Array.! (i-1,j-1)-      ]+    dist (0, j) = j+    dist (i, 0) = i+    dist (i, j) =+      minimum+        [ table Array.! (i - 1, j) + 1+        , table Array.! (i, j - 1) + 1+        , if x Array.! i == y Array.! j+            then table Array.! (i - 1, j - 1)+            else 1 + table Array.! (i - 1, j - 1)+        ]  -- | Utility function, many commands do not accept additional flags. This -- action fails with a helpful error message if the user supplies any extra.--- noExtraFlags :: [String] -> IO () noExtraFlags [] = return () noExtraFlags extraFlags =   dieNoVerbosity $ "Unrecognised flags: " ++ intercalate ", " extraFlags---TODO: eliminate this function and turn it into a variant on commandAddAction++-- TODO: eliminate this function and turn it into a variant on commandAddAction --      instead like commandAddActionNoArgs that doesn't supply the [String]  -- | Helper function for creating globalCommand description getNormalCommandDescriptions :: [Command action] -> [(String, String)] getNormalCommandDescriptions cmds =   [ (name, description)-  | Command name description _ NormalCommand <- cmds ]+  | Command name description _ NormalCommand <- cmds+  ]  helpCommandUI :: CommandUI () helpCommandUI =-  (mkCommandUI-    "help"-    "Help about commands."-    ["[FLAGS]", "COMMAND [FLAGS]"]-    ()-    (const []))-  {-    commandNotes = Just $ \pname ->-       "Examples:\n"-    ++ "  " ++ pname ++ " help help\n"-    ++ "    Oh, appararently you already know this.\n"-  }+  ( mkCommandUI+      "help"+      "Help about commands."+      ["[FLAGS]", "COMMAND [FLAGS]"]+      ()+      (const [])+  )+    { commandNotes = Just $ \pname ->+        "Examples:\n"+          ++ "  "+          ++ pname+          ++ " help help\n"+          ++ "    Oh, apparently you already know this.\n"+    }  -- | wraps a @CommandUI@ together with a function that turns it into a @Command@. -- By hiding the type of flags for the UI allows construction of a list of all UIs at the
src/Distribution/Simple/Compiler.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Compiler -- Copyright   :  Isaac Jones 2003-2004@@ -20,87 +22,108 @@ -- only know about a single global package collection but GHC has a global and -- per-user one and it lets you create arbitrary other package databases. We do -- not yet fully support this latter feature.--module Distribution.Simple.Compiler (-        -- * Haskell implementations-        module Distribution.Compiler,-        Compiler(..),-        showCompilerId, showCompilerIdWithAbi,-        compilerFlavor, compilerVersion,-        compilerCompatFlavor,-        compilerCompatVersion,-        compilerInfo,+module Distribution.Simple.Compiler+  ( -- * Haskell implementations+      module Distribution.Compiler+  , Compiler (..)+  , showCompilerId+  , showCompilerIdWithAbi+  , compilerFlavor+  , compilerVersion+  , compilerCompatFlavor+  , compilerCompatVersion+  , compilerInfo -        -- * Support for package databases-        PackageDB(..),-        PackageDBStack,-        registrationPackageDB,-        absolutePackageDBPaths,-        absolutePackageDBPath,+    -- * Support for package databases+  , PackageDB+  , PackageDBStack+  , PackageDBCWD+  , PackageDBStackCWD+  , PackageDBX (..)+  , PackageDBStackX+  , PackageDBS+  , PackageDBStackS+  , registrationPackageDB+  , absolutePackageDBPaths+  , absolutePackageDBPath+  , interpretPackageDB+  , interpretPackageDBStack+  , coercePackageDB+  , coercePackageDBStack -        -- * Support for optimisation levels-        OptimisationLevel(..),-        flagToOptimisationLevel,+    -- * Support for optimisation levels+  , OptimisationLevel (..)+  , flagToOptimisationLevel -        -- * Support for debug info levels-        DebugInfoLevel(..),-        flagToDebugInfoLevel,+    -- * Support for debug info levels+  , DebugInfoLevel (..)+  , flagToDebugInfoLevel -        -- * Support for language extensions-        CompilerFlag,-        languageToFlags,-        unsupportedLanguages,-        extensionsToFlags,-        unsupportedExtensions,-        parmakeSupported,-        reexportedModulesSupported,-        renamingPackageFlagsSupported,-        unifiedIPIDRequired,-        packageKeySupported,-        unitIdSupported,-        coverageSupported,-        profilingSupported,-        backpackSupported,-        arResponseFilesSupported,-        libraryDynDirSupported,-        libraryVisibilitySupported,+    -- * Support for language extensions+  , CompilerFlag+  , languageToFlags+  , unsupportedLanguages+  , extensionsToFlags+  , unsupportedExtensions+  , parmakeSupported+  , reexportedModulesSupported+  , renamingPackageFlagsSupported+  , unifiedIPIDRequired+  , packageKeySupported+  , unitIdSupported+  , coverageSupported+  , profilingSupported+  , profilingDynamicSupported+  , profilingDynamicSupportedOrUnknown+  , profilingVanillaSupported+  , profilingVanillaSupportedOrUnknown+  , dynamicSupported+  , backpackSupported+  , arResponseFilesSupported+  , arDashLSupported+  , libraryDynDirSupported+  , libraryVisibilitySupported+  , jsemSupported+  , reexportedAsSupported -        -- * Support for profiling detail levels-        ProfDetailLevel(..),-        knownProfDetailLevels,-        flagToProfDetailLevel,-        showProfDetailLevel,+    -- * Support for profiling detail levels+  , ProfDetailLevel (..)+  , knownProfDetailLevels+  , flagToProfDetailLevel+  , showProfDetailLevel   ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Pretty+import Prelude ()  import Distribution.Compiler+import Distribution.Simple.Utils+import Distribution.Utils.Path import Distribution.Version+ import Language.Haskell.Extension-import Distribution.Simple.Utils  import qualified Data.Map as Map (lookup) import System.Directory (canonicalizePath) -data Compiler = Compiler {-        compilerId              :: CompilerId,-        -- ^ Compiler flavour and version.-        compilerAbiTag          :: AbiTag,-        -- ^ Tag for distinguishing incompatible ABI's on the same-        -- architecture/os.-        compilerCompat          :: [CompilerId],-        -- ^ Other implementations that this compiler claims to be-        -- compatible with.-        compilerLanguages       :: [(Language, CompilerFlag)],-        -- ^ Supported language standards.-        compilerExtensions      :: [(Extension, Maybe CompilerFlag)],-        -- ^ Supported extensions.-        compilerProperties      :: Map String String-        -- ^ A key-value map for properties not covered by the above fields.-    }-    deriving (Eq, Generic, Typeable, Show, Read)+data Compiler = Compiler+  { compilerId :: CompilerId+  -- ^ Compiler flavour and version.+  , compilerAbiTag :: AbiTag+  -- ^ Tag for distinguishing incompatible ABI's on the same+  -- architecture/os.+  , compilerCompat :: [CompilerId]+  -- ^ Other implementations that this compiler claims to be+  -- compatible with.+  , compilerLanguages :: [(Language, CompilerFlag)]+  -- ^ Supported language standards.+  , compilerExtensions :: [(Extension, Maybe CompilerFlag)]+  -- ^ Supported extensions.+  , compilerProperties :: Map String String+  -- ^ A key-value map for properties not covered by the above fields.+  }+  deriving (Eq, Generic, Show, Read)  instance Binary Compiler instance Structured Compiler@@ -110,30 +133,27 @@  showCompilerIdWithAbi :: Compiler -> String showCompilerIdWithAbi comp =-  prettyShow (compilerId comp) ++-  case compilerAbiTag comp of-    NoAbiTag  -> []-    AbiTag xs -> '-':xs+  prettyShow (compilerId comp)+    ++ case compilerAbiTag comp of+      NoAbiTag -> []+      AbiTag xs -> '-' : xs -compilerFlavor ::  Compiler -> CompilerFlavor+compilerFlavor :: Compiler -> CompilerFlavor compilerFlavor = (\(CompilerId f _) -> f) . compilerId  compilerVersion :: Compiler -> Version compilerVersion = (\(CompilerId _ v) -> v) . compilerId - -- | Is this compiler compatible with the compiler flavour we're interested in? -- -- For example this checks if the compiler is actually GHC or is another -- compiler that claims to be compatible with some version of GHC, e.g. GHCJS. -- -- > if compilerCompatFlavor GHC compiler then ... else ...--- compilerCompatFlavor :: CompilerFlavor -> Compiler -> Bool compilerCompatFlavor flavor comp =-    flavor == compilerFlavor comp- || flavor `elem` [ flavor' | CompilerId flavor' _ <- compilerCompat comp ]-+  flavor == compilerFlavor comp+    || flavor `elem` [flavor' | CompilerId flavor' _ <- compilerCompat comp]  -- | Is this compiler compatible with the compiler flavour we're interested in, -- and if so what version does it claim to be compatible with.@@ -144,38 +164,44 @@ -- > case compilerCompatVersion GHC compiler of -- >   Just (Version (7:_)) -> ... -- >   _                    -> ...--- compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version compilerCompatVersion flavor comp   | compilerFlavor comp == flavor = Just (compilerVersion comp)-  | otherwise    =-      listToMaybe [ v | CompilerId fl v <- compilerCompat comp, fl == flavor ]+  | otherwise =+      listToMaybe [v | CompilerId fl v <- compilerCompat comp, fl == flavor]  compilerInfo :: Compiler -> CompilerInfo-compilerInfo c = CompilerInfo (compilerId c)-                              (compilerAbiTag c)-                              (Just . compilerCompat $ c)-                              (Just . map fst . compilerLanguages $ c)-                              (Just . map fst . compilerExtensions $ c)+compilerInfo c =+  CompilerInfo+    (compilerId c)+    (compilerAbiTag c)+    (Just . compilerCompat $ c)+    (Just . map fst . compilerLanguages $ c)+    (Just . map fst . compilerExtensions $ c)  -- ------------------------------------------------------------+ -- * Package databases+ -- ------------------------------------------------------------ --- |Some compilers have a notion of a database of available packages.--- For some there is just one global db of packages, other compilers--- support a per-user or an arbitrary db specified at some location in--- the file system. This can be used to build isloated environments of--- packages, for example to build a collection of related packages--- without installing them globally.+-- | Some compilers have a notion of a database of available packages.+--  For some there is just one global db of packages, other compilers+--  support a per-user or an arbitrary db specified at some location in+--  the file system. This can be used to build isolated environments of+--  packages, for example to build a collection of related packages+--  without installing them globally. ---data PackageDB = GlobalPackageDB-               | UserPackageDB-               | SpecificPackageDB FilePath-    deriving (Eq, Generic, Ord, Show, Read, Typeable)+--  Abstracted over+data PackageDBX fp+  = GlobalPackageDB+  | UserPackageDB+  | -- | NB: the path might be relative or it might be absolute+    SpecificPackageDB fp+  deriving (Eq, Generic, Ord, Show, Read, Functor, Foldable, Traversable) -instance Binary PackageDB-instance Structured PackageDB+instance Binary fp => Binary (PackageDBX fp)+instance Structured fp => Structured (PackageDBX fp)  -- | We typically get packages from several databases, and stack them -- together. This type lets us be explicit about that stacking. For example@@ -192,114 +218,165 @@ -- we can use several custom package dbs and the user package db together. -- -- When it comes to writing, the top most (last) package is used.----type PackageDBStack = [PackageDB]+type PackageDBStackX from = [PackageDBX from] +type PackageDB = PackageDBX (SymbolicPath Pkg (Dir PkgDB))+type PackageDBStack = PackageDBStackX (SymbolicPath Pkg (Dir PkgDB))++type PackageDBS from = PackageDBX (SymbolicPath from (Dir PkgDB))+type PackageDBStackS from = PackageDBStackX (SymbolicPath from (Dir PkgDB))++type PackageDBCWD = PackageDBX FilePath+type PackageDBStackCWD = PackageDBStackX FilePath+ -- | Return the package that we should register into. This is the package db at -- the top of the stack.----registrationPackageDB :: PackageDBStack -> PackageDB-registrationPackageDB dbs  = case safeLast dbs of+registrationPackageDB :: PackageDBStackX from -> PackageDBX from+registrationPackageDB dbs = case safeLast dbs of   Nothing -> error "internal error: empty package db set"-  Just p  -> p+  Just p -> p  -- | Make package paths absolute+absolutePackageDBPaths+  :: Maybe (SymbolicPath CWD (Dir Pkg))+  -> PackageDBStack+  -> IO PackageDBStack+absolutePackageDBPaths mbWorkDir = traverse $ absolutePackageDBPath mbWorkDir +absolutePackageDBPath+  :: Maybe (SymbolicPath CWD (Dir Pkg))+  -> PackageDB+  -> IO PackageDB+absolutePackageDBPath _ GlobalPackageDB = return GlobalPackageDB+absolutePackageDBPath _ UserPackageDB = return UserPackageDB+absolutePackageDBPath mbWorkDir (SpecificPackageDB db) = do+  let db' =+        case symbolicPathRelative_maybe db of+          Nothing -> getSymbolicPath db+          Just rel_path -> interpretSymbolicPath mbWorkDir rel_path+  SpecificPackageDB . makeSymbolicPath <$> canonicalizePath db' -absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack-absolutePackageDBPaths = traverse absolutePackageDBPath+interpretPackageDB :: Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageDBCWD+interpretPackageDB _ GlobalPackageDB = GlobalPackageDB+interpretPackageDB _ UserPackageDB = UserPackageDB+interpretPackageDB mbWorkDir (SpecificPackageDB db) =+  SpecificPackageDB (interpretSymbolicPath mbWorkDir db) -absolutePackageDBPath :: PackageDB -> IO PackageDB-absolutePackageDBPath GlobalPackageDB        = return GlobalPackageDB-absolutePackageDBPath UserPackageDB          = return UserPackageDB-absolutePackageDBPath (SpecificPackageDB db) =-  SpecificPackageDB `liftM` canonicalizePath db+interpretPackageDBStack :: Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDBStack -> PackageDBStackCWD+interpretPackageDBStack mbWorkDir = map (interpretPackageDB mbWorkDir) +-- | Transform a package db using a FilePath into one using symbolic paths.+coercePackageDB :: PackageDBCWD -> PackageDBX (SymbolicPath CWD (Dir PkgDB))+coercePackageDB GlobalPackageDB = GlobalPackageDB+coercePackageDB UserPackageDB = UserPackageDB+coercePackageDB (SpecificPackageDB db) = SpecificPackageDB (makeSymbolicPath db)++coercePackageDBStack+  :: [PackageDBCWD]+  -> [PackageDBX (SymbolicPath CWD (Dir PkgDB))]+coercePackageDBStack = map coercePackageDB+ -- ------------------------------------------------------------+ -- * Optimisation levels+ -- ------------------------------------------------------------  -- | Some compilers support optimising. Some have different levels. -- For compilers that do not the level is just capped to the level -- they do support.----data OptimisationLevel = NoOptimisation-                       | NormalOptimisation-                       | MaximumOptimisation-    deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)+data OptimisationLevel+  = NoOptimisation+  | NormalOptimisation+  | MaximumOptimisation+  deriving (Bounded, Enum, Eq, Generic, Read, Show)  instance Binary OptimisationLevel instance Structured OptimisationLevel  flagToOptimisationLevel :: Maybe String -> OptimisationLevel-flagToOptimisationLevel Nothing  = NormalOptimisation+flagToOptimisationLevel Nothing = NormalOptimisation flagToOptimisationLevel (Just s) = case reads s of   [(i, "")]     | i >= fromEnum (minBound :: OptimisationLevel)-   && i <= fromEnum (maxBound :: OptimisationLevel)-                -> toEnum i-    | otherwise -> error $ "Bad optimisation level: " ++ show i-                        ++ ". Valid values are 0..2"-  _             -> error $ "Can't parse optimisation level " ++ s+        && i <= fromEnum (maxBound :: OptimisationLevel) ->+        toEnum i+    | otherwise ->+        error $+          "Bad optimisation level: "+            ++ show i+            ++ ". Valid values are 0..2"+  _ -> error $ "Can't parse optimisation level " ++ s  -- ------------------------------------------------------------+ -- * Debug info levels+ -- ------------------------------------------------------------  -- | Some compilers support emitting debug info. Some have different -- levels.  For compilers that do not the level is just capped to the -- level they do support.----data DebugInfoLevel = NoDebugInfo-                    | MinimalDebugInfo-                    | NormalDebugInfo-                    | MaximalDebugInfo-    deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)+data DebugInfoLevel+  = NoDebugInfo+  | MinimalDebugInfo+  | NormalDebugInfo+  | MaximalDebugInfo+  deriving (Bounded, Enum, Eq, Generic, Read, Show)  instance Binary DebugInfoLevel instance Structured DebugInfoLevel  flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel-flagToDebugInfoLevel Nothing  = NormalDebugInfo+flagToDebugInfoLevel Nothing = NormalDebugInfo flagToDebugInfoLevel (Just s) = case reads s of   [(i, "")]     | i >= fromEnum (minBound :: DebugInfoLevel)-   && i <= fromEnum (maxBound :: DebugInfoLevel)-                -> toEnum i-    | otherwise -> error $ "Bad debug info level: " ++ show i-                        ++ ". Valid values are 0..3"-  _             -> error $ "Can't parse debug info level " ++ s+        && i <= fromEnum (maxBound :: DebugInfoLevel) ->+        toEnum i+    | otherwise ->+        error $+          "Bad debug info level: "+            ++ show i+            ++ ". Valid values are 0..3"+  _ -> error $ "Can't parse debug info level " ++ s  -- ------------------------------------------------------------+ -- * Languages and Extensions+ -- ------------------------------------------------------------  unsupportedLanguages :: Compiler -> [Language] -> [Language] unsupportedLanguages comp langs =-  [ lang | lang <- langs-         , isNothing (languageToFlag comp lang) ]+  [ lang | lang <- langs, isNothing (languageToFlag comp lang)+  ]  languageToFlags :: Compiler -> Maybe Language -> [CompilerFlag]-languageToFlags comp = filter (not . null)-                     . catMaybes . map (languageToFlag comp)-                     . maybe [Haskell98] (\x->[x])+languageToFlags comp =+  filter (not . null)+    . catMaybes+    . map (languageToFlag comp)+    . maybe [Haskell98] (\x -> [x])  languageToFlag :: Compiler -> Language -> Maybe CompilerFlag languageToFlag comp ext = lookup ext (compilerLanguages comp) ---- |For the given compiler, return the extensions it does not support.+-- | For the given compiler, return the extensions it does not support. unsupportedExtensions :: Compiler -> [Extension] -> [Extension] unsupportedExtensions comp exts =-  [ ext | ext <- exts-        , isNothing (extensionToFlag' comp ext) ]+  [ ext | ext <- exts, isNothing (extensionToFlag' comp ext)+  ]  type CompilerFlag = String --- |For the given compiler, return the flags for the supported extensions.+-- | For the given compiler, return the flags for the supported extensions. extensionsToFlags :: Compiler -> [Extension] -> [CompilerFlag]-extensionsToFlags comp = nub . filter (not . null)-                       . catMaybes . map (extensionToFlag comp)+extensionsToFlags comp =+  nub+    . filter (not . null)+    . catMaybes+    . map (extensionToFlag comp)  -- | Looks up the flag for a given extension, for a given compiler. -- Ignores the subtlety of extensions which lack associated flags.@@ -328,8 +405,9 @@  -- | Does this compiler support thinning/renaming on package flags? renamingPackageFlagsSupported :: Compiler -> Bool-renamingPackageFlagsSupported = ghcSupported-  "Support thinning and renaming package flags"+renamingPackageFlagsSupported =+  ghcSupported+    "Support thinning and renaming package flags"  -- | Does this compiler have unified IPIDs (so no package keys) unifiedIPIDRequired :: Compiler -> Bool@@ -347,63 +425,134 @@ backpackSupported :: Compiler -> Bool backpackSupported = ghcSupported "Support Backpack" +-- | Does this compiler support the -jsem option?+jsemSupported :: Compiler -> Bool+jsemSupported comp = case compilerFlavor comp of+  GHC -> v >= mkVersion [9, 7]+  _ -> False+  where+    v = compilerVersion comp++-- | 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])-  _   -> False- where-  v = compilerVersion comp+    -- Not just v >= mkVersion [8,0,1,20161022], as there+    -- are many GHC 8.1 nightlies which don't support this.+    ( (v >= mkVersion [8, 0, 1, 20161022] && v < mkVersion [8, 1])+        || v >= mkVersion [8, 1, 20161021]+    )+  _ -> False+  where+    v = compilerVersion comp  -- | Does this compiler's "ar" command supports response file -- arguments (i.e. @file-style arguments). arResponseFilesSupported :: Compiler -> Bool arResponseFilesSupported = ghcSupported "ar supports at file" +-- | Does this compiler's "ar" command support llvm-ar's -L flag,+-- which compels the archiver to add an input archive's members+-- rather than adding the archive itself.+arDashLSupported :: Compiler -> Bool+arDashLSupported = ghcSupported "ar supports -L"+ -- | Does this compiler support Haskell program coverage? coverageSupported :: Compiler -> Bool coverageSupported comp =   case compilerFlavor comp of-    GHC   -> True+    GHC -> True     GHCJS -> True-    _     -> False+    _ -> False  -- | Does this compiler support profiling? profilingSupported :: Compiler -> Bool profilingSupported comp =   case compilerFlavor comp of-    GHC   -> True+    GHC -> True     GHCJS -> True-    _     -> False+    _ -> False +-- | Returns Just if we can certainly determine whether a way is supported+-- if we don't know, return Nothing+waySupported :: String -> Compiler -> Maybe Bool+waySupported way comp =+  case compilerFlavor comp of+    GHC ->+      -- Information about compiler ways is only accurately reported after+      -- 9.10.1. Which is useful as this is before profiling dynamic support+      -- was introduced. (See GHC #24881)+      if compilerVersion comp >= mkVersion [9, 10, 1]+        then case Map.lookup "RTS ways" (compilerProperties comp) of+          Just ways -> Just (way `elem` words ways)+          Nothing -> Just False+        else Nothing+    _ -> Nothing++-- | Either profiling is definitely supported or we don't know (so assume+-- it is)+profilingVanillaSupportedOrUnknown :: Compiler -> Bool+profilingVanillaSupportedOrUnknown comp = profilingVanillaSupported comp `elem` [Just True, Nothing]++-- | Is the compiler distributed with profiling libraries+profilingVanillaSupported :: Compiler -> Maybe Bool+profilingVanillaSupported comp = waySupported "p" comp++-- | Is the compiler distributed with profiling dynamic libraries+profilingDynamicSupported :: Compiler -> Maybe Bool+profilingDynamicSupported comp+  | GHC <- compilerFlavor comp+  , -- Certainly not before 9.11, as prof+dyn was not implemented yet.+    compilerVersion comp <= mkVersion [9, 11, 0] =+      Just False+  | otherwise =+      waySupported "p_dyn" comp++-- | Either profiling dynamic is definitely supported or we don't know (so assume+-- it is)+profilingDynamicSupportedOrUnknown :: Compiler -> Bool+profilingDynamicSupportedOrUnknown comp =+  profilingDynamicSupported comp `elem` [Just True, Nothing]++-- | Is the compiler distributed with dynamic libraries+dynamicSupported :: Compiler -> Maybe Bool+dynamicSupported comp = waySupported "dyn" comp+ -- | Does this compiler support a package database entry with: -- "visibility"? libraryVisibilitySupported :: Compiler -> Bool libraryVisibilitySupported comp = case compilerFlavor comp of-  GHC -> v >= mkVersion [8,8]-  _   -> False- where-  v = compilerVersion comp+  GHC -> v >= mkVersion [8, 8]+  _ -> False+  where+    v = compilerVersion comp  -- | Utility function for GHC only features ghcSupported :: String -> Compiler -> Bool ghcSupported key comp =   case compilerFlavor comp of-    GHC   -> checkProp+    GHC -> checkProp     GHCJS -> checkProp-    _     -> False-  where checkProp =-          case Map.lookup key (compilerProperties comp) of-            Just "YES" -> True-            _          -> False+    _ -> False+  where+    checkProp =+      case Map.lookup key (compilerProperties comp) of+        Just "YES" -> True+        _ -> False  -- ------------------------------------------------------------+ -- * Profiling detail level+ -- ------------------------------------------------------------  -- | Some compilers (notably GHC) support profiling and can instrument@@ -412,42 +561,47 @@ -- For compilers that do not support this notion or the particular detail -- levels, this is either ignored or just capped to some similar level -- they do support.----data ProfDetailLevel = ProfDetailNone-                     | ProfDetailDefault-                     | ProfDetailExportedFunctions-                     | ProfDetailToplevelFunctions-                     | ProfDetailAllFunctions-                     | ProfDetailOther String-    deriving (Eq, Generic, Read, Show, Typeable)+data ProfDetailLevel+  = ProfDetailNone+  | ProfDetailDefault+  | ProfDetailExportedFunctions+  | ProfDetailToplevelFunctions+  | ProfDetailAllFunctions+  | ProfDetailTopLate+  | ProfDetailOther String+  deriving (Eq, Generic, Read, Show)  instance Binary ProfDetailLevel instance Structured ProfDetailLevel  flagToProfDetailLevel :: String -> ProfDetailLevel flagToProfDetailLevel "" = ProfDetailDefault-flagToProfDetailLevel s  =-    case lookup (lowercase s)-                [ (name, value)-                | (primary, aliases, value) <- knownProfDetailLevels-                , name <- primary : aliases ]-      of Just value -> value-         Nothing    -> ProfDetailOther s+flagToProfDetailLevel s =+  case lookup+    (lowercase s)+    [ (name, value)+    | (primary, aliases, value) <- knownProfDetailLevels+    , name <- primary : aliases+    ] of+    Just value -> value+    Nothing -> ProfDetailOther s  knownProfDetailLevels :: [(String, [String], ProfDetailLevel)] knownProfDetailLevels =-  [ ("default",            [],                  ProfDetailDefault)-  , ("none",               [],                  ProfDetailNone)-  , ("exported-functions", ["exported"],        ProfDetailExportedFunctions)+  [ ("default", [], ProfDetailDefault)+  , ("none", [], ProfDetailNone)+  , ("exported-functions", ["exported"], ProfDetailExportedFunctions)   , ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions)-  , ("all-functions",      ["all"],             ProfDetailAllFunctions)+  , ("all-functions", ["all"], ProfDetailAllFunctions)+  , ("late-toplevel", ["late"], ProfDetailTopLate)   ]  showProfDetailLevel :: ProfDetailLevel -> String showProfDetailLevel dl = case dl of-    ProfDetailNone              -> "none"-    ProfDetailDefault           -> "default"-    ProfDetailExportedFunctions -> "exported-functions"-    ProfDetailToplevelFunctions -> "toplevel-functions"-    ProfDetailAllFunctions      -> "all-functions"-    ProfDetailOther other       -> other+  ProfDetailNone -> "none"+  ProfDetailDefault -> "default"+  ProfDetailExportedFunctions -> "exported-functions"+  ProfDetailToplevelFunctions -> "toplevel-functions"+  ProfDetailAllFunctions -> "all-functions"+  ProfDetailTopLate -> "late-toplevel"+  ProfDetailOther other -> other
src/Distribution/Simple/Configure.hs view
@@ -1,2085 +1,2978 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Configure--- Copyright   :  Isaac Jones 2003-2005--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This deals with the /configure/ phase. It provides the 'configure' action--- which is given the package description and configure flags. It then tries--- to: configure the compiler; resolves any conditionals in the package--- description; resolve the package dependencies; check if all the extensions--- used by this package are supported by the compiler; check that all the build--- tools are available (including version checks if appropriate); checks for--- any required @pkg-config@ packages (updating the 'BuildInfo' with the--- results)------ Then based on all this it saves the info in the 'LocalBuildInfo' and writes--- it out to the @dist\/setup-config@ file. It also displays various details to--- the user, the amount of information displayed depending on the verbosity--- level.--module Distribution.Simple.Configure-  ( configure-  , writePersistBuildConfig-  , getConfigStateFile-  , getPersistBuildConfig-  , checkPersistBuildConfigOutdated-  , tryGetPersistBuildConfig-  , maybeGetPersistBuildConfig-  , findDistPref, findDistPrefOrDefault-  , getInternalLibraries-  , computeComponentId-  , computeCompatPackageKey-  , localBuildInfoFile-  , getInstalledPackages-  , getInstalledPackagesMonitorFiles-  , getPackageDBContents-  , configCompilerEx, configCompilerAuxEx-  , computeEffectiveProfiling-  , ccLdOptionsBuildInfo-  , checkForeignDeps-  , interpretPackageDbFlags-  , ConfigStateFileError(..)-  , tryGetConfigStateFile-  , platformDefines,-  ) where--import qualified Prelude as Unsafe (tail)-import Distribution.Compat.Prelude--import Distribution.Compiler-import Distribution.Types.IncludeRenaming-import Distribution.Utils.NubList-import Distribution.Simple.Compiler-import Distribution.Simple.PreProcess-import Distribution.Package-import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.InstalledPackageInfo (InstalledPackageInfo)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import Distribution.PackageDescription-import Distribution.PackageDescription.PrettyPrint-import Distribution.PackageDescription.Configuration-import Distribution.PackageDescription.Check hiding (doesFileExist)-import Distribution.Simple.BuildToolDepends-import Distribution.Simple.Program-import Distribution.Simple.Setup as Setup-import Distribution.Simple.BuildTarget-import Distribution.Simple.LocalBuildInfo-import Distribution.Types.PackageVersionConstraint-import Distribution.Types.LocalBuildInfo-import Distribution.Types.ComponentRequestedSpec-import Distribution.Types.GivenComponent-import Distribution.Simple.Utils-import Distribution.System-import Distribution.Version-import Distribution.Verbosity-import qualified Distribution.Compat.Graph as Graph-import Distribution.Compat.Stack-import Distribution.Backpack.Configure-import Distribution.Backpack.DescribeUnitId-import Distribution.Backpack.PreExistingComponent-import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour)-import Distribution.Backpack.Id-import Distribution.Utils.LogProgress--import qualified Distribution.Simple.GHC   as GHC-import qualified Distribution.Simple.GHCJS as GHCJS-import qualified Distribution.Simple.UHC   as UHC-import qualified Distribution.Simple.HaskellSuite as HaskellSuite--import Control.Exception-    ( try )-import Distribution.Utils.Structured ( structuredDecodeOrFailIO, structuredEncode )-import Distribution.Compat.Directory ( listDirectory )-import Data.ByteString.Lazy          ( ByteString )-import qualified Data.ByteString            as BS-import qualified Data.ByteString.Lazy.Char8 as BLC8-import Data.List-    ( (\\), inits, stripPrefix, intersect, dropWhileEnd )-import qualified Data.Map as Map-import System.Directory-    ( canonicalizePath, createDirectoryIfMissing, doesFileExist-    , getTemporaryDirectory, removeFile)-import System.FilePath-    ( (</>), isAbsolute, takeDirectory )-import Distribution.Compat.Directory-    ( doesPathExist )-import qualified System.Info-    ( compilerName, compilerVersion )-import System.IO-    ( hPutStrLn, hClose )-import Distribution.Pretty-    ( pretty, defaultStyle, prettyShow )-import Distribution.Parsec-    ( simpleParsec )-import Text.PrettyPrint-    ( Doc, ($+$), char, comma, hsep, nest-    , punctuate, quotes, render, renderStyle, sep, text )-import Distribution.Compat.Environment ( lookupEnv )--import qualified Data.Set as Set-import qualified Distribution.Compat.NonEmptySet as NES---type UseExternalInternalDeps = Bool---- | The errors that can be thrown when reading the @setup-config@ file.-data ConfigStateFileError-    = ConfigStateFileNoHeader -- ^ No header found.-    | ConfigStateFileBadHeader -- ^ Incorrect header.-    | ConfigStateFileNoParse -- ^ Cannot parse file contents.-    | ConfigStateFileMissing -- ^ No file!-    | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier-      (Either ConfigStateFileError LocalBuildInfo) -- ^ Mismatched version.-  deriving (Typeable)---- | Format a 'ConfigStateFileError' as a user-facing error message.-dispConfigStateFileError :: ConfigStateFileError -> Doc-dispConfigStateFileError ConfigStateFileNoHeader =-    text "Saved package config file header is missing."-    <+> text "Re-run the 'configure' command."-dispConfigStateFileError ConfigStateFileBadHeader =-    text "Saved package config file header is corrupt."-    <+> text "Re-run the 'configure' command."-dispConfigStateFileError ConfigStateFileNoParse =-    text "Saved package config file is corrupt."-    <+> text "Re-run the 'configure' command."-dispConfigStateFileError ConfigStateFileMissing =-    text "Run the 'configure' command first."-dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) =-    text "Saved package config file is outdated:"-    $+$ badCabal $+$ badCompiler-    $+$ text "Re-run the 'configure' command."-    where-      badCabal =-          text "• the Cabal version changed from"-          <+> pretty oldCabal <+> "to" <+> pretty currentCabalId-      badCompiler-        | oldCompiler == currentCompilerId = mempty-        | otherwise =-            text "• the compiler changed from"-            <+> pretty oldCompiler <+> "to" <+> pretty currentCompilerId--instance Show ConfigStateFileError where-    show = renderStyle defaultStyle . dispConfigStateFileError--instance Exception ConfigStateFileError---- | Read the 'localBuildInfoFile'.  Throw an exception if the file is--- missing, if the file cannot be read, or if the file was created by an older--- version of Cabal.-getConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.-                   -> IO LocalBuildInfo-getConfigStateFile filename = do-    exists <- doesFileExist filename-    unless exists $ throwIO ConfigStateFileMissing-    -- Read the config file into a strict ByteString to avoid problems with-    -- lazy I/O, then convert to lazy because the binary package needs that.-    contents <- BS.readFile filename-    let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents])--    (cabalId, compId) <- parseHeader header--    let getStoredValue = do-          result <- structuredDecodeOrFailIO (BLC8.tail body)-          case result of-            Left _ -> throwIO ConfigStateFileNoParse-            Right x -> return x-        deferErrorIfBadVersion act-          | cabalId /= currentCabalId = do-              eResult <- try act-              throwIO $ ConfigStateFileBadVersion cabalId compId eResult-          | otherwise = act-    deferErrorIfBadVersion getStoredValue-  where-    _ = callStack -- TODO: attach call stack to exception---- | Read the 'localBuildInfoFile', returning either an error or the local build--- info.-tryGetConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.-                      -> IO (Either ConfigStateFileError LocalBuildInfo)-tryGetConfigStateFile = try . getConfigStateFile---- | Try to read the 'localBuildInfoFile'.-tryGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.-                         -> IO (Either ConfigStateFileError LocalBuildInfo)-tryGetPersistBuildConfig = try . getPersistBuildConfig---- | Read the 'localBuildInfoFile'. Throw an exception if the file is--- missing, if the file cannot be read, or if the file was created by an older--- version of Cabal.-getPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.-                      -> IO LocalBuildInfo-getPersistBuildConfig = getConfigStateFile . localBuildInfoFile---- | Try to read the 'localBuildInfoFile'.-maybeGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.-                           -> IO (Maybe LocalBuildInfo)-maybeGetPersistBuildConfig =-    liftM (either (const Nothing) Just) . tryGetPersistBuildConfig---- | After running configure, output the 'LocalBuildInfo' to the--- 'localBuildInfoFile'.-writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path.-                        -> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write.-                        -> IO ()-writePersistBuildConfig distPref lbi = do-    createDirectoryIfMissing False distPref-    writeFileAtomic (localBuildInfoFile distPref) $-      BLC8.unlines [showHeader pkgId, structuredEncode lbi]-  where-    pkgId = localPackage lbi---- | Identifier of the current Cabal package.-currentCabalId :: PackageIdentifier-currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion---- | Identifier of the current compiler package.-currentCompilerId :: PackageIdentifier-currentCompilerId = PackageIdentifier (mkPackageName System.Info.compilerName)-                                      (mkVersion' System.Info.compilerVersion)---- | Parse the @setup-config@ file header, returning the package identifiers--- for Cabal and the compiler.-parseHeader :: ByteString -- ^ The file contents.-            -> IO (PackageIdentifier, PackageIdentifier)-parseHeader header = case BLC8.words header of-  ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId,-   "using", compId] ->-      maybe (throwIO ConfigStateFileBadHeader) return $ do-          _ <- simpleParsec (fromUTF8LBS pkgId) :: Maybe PackageIdentifier-          cabalId' <- simpleParsec (BLC8.unpack cabalId)-          compId' <- simpleParsec (BLC8.unpack compId)-          return (cabalId', compId')-  _ -> throwIO ConfigStateFileNoHeader---- | Generate the @setup-config@ file header.-showHeader :: PackageIdentifier -- ^ The processed package.-            -> ByteString-showHeader pkgId = BLC8.unwords-    [ "Saved", "package", "config", "for"-    , toUTF8LBS $ prettyShow pkgId-    , "written", "by"-    , BLC8.pack $ prettyShow currentCabalId-    , "using"-    , BLC8.pack $ prettyShow currentCompilerId-    ]---- | Check that localBuildInfoFile is up-to-date with respect to the--- .cabal file.-checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool-checkPersistBuildConfigOutdated distPref pkg_descr_file =-  pkg_descr_file `moreRecentFile` localBuildInfoFile distPref---- | Get the path of @dist\/setup-config@.-localBuildInfoFile :: FilePath -- ^ The @dist@ directory path.-                    -> FilePath-localBuildInfoFile distPref = distPref </> "setup-config"---- -------------------------------------------------------------------------------- * Configuration--- --------------------------------------------------------------------------------- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken--- from (in order of highest to lowest preference) the override prefix, the--- \"CABAL_BUILDDIR\" environment variable, or the default prefix.-findDistPref :: FilePath  -- ^ default \"dist\" prefix-             -> Setup.Flag FilePath  -- ^ override \"dist\" prefix-             -> IO FilePath-findDistPref defDistPref overrideDistPref = do-    envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR")-    return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref)-  where-    parseEnvDistPref env =-      case env of-        Just distPref | not (null distPref) -> toFlag distPref-        _ -> NoFlag---- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken--- from (in order of highest to lowest preference) the override prefix, the--- \"CABAL_BUILDDIR\" environment variable, or 'defaultDistPref' is used. Call--- this function to resolve a @*DistPref@ flag whenever it is not known to be--- set. (The @*DistPref@ flags are always set to a definite value before--- invoking 'UserHooks'.)-findDistPrefOrDefault :: Setup.Flag FilePath  -- ^ override \"dist\" prefix-                      -> IO FilePath-findDistPrefOrDefault = findDistPref defaultDistPref---- |Perform the \"@.\/setup configure@\" action.--- Returns the @.setup-config@ file.-configure :: (GenericPackageDescription, HookedBuildInfo)-          -> ConfigFlags -> IO LocalBuildInfo-configure (pkg_descr0, pbi) cfg = do-    -- Determine the component we are configuring, if a user specified-    -- one on the command line.  We use a fake, flattened version of-    -- the package since at this point, we're not really sure what-    -- components we *can* configure.  @Nothing@ means that we should-    -- configure everything (the old behavior).-    (mb_cname :: Maybe ComponentName) <- do-        let flat_pkg_descr = flattenPackageDescription pkg_descr0-        targets <- readBuildTargets verbosity flat_pkg_descr (configArgs cfg)-        -- TODO: bleat if you use the module/file syntax-        let targets' = [ cname | BuildTargetComponent cname <- targets ]-        case targets' of-            _ | null (configArgs cfg) -> return Nothing-            [cname] -> return (Just cname)-            [] -> die' verbosity "No valid component targets found"-            _  -> die' verbosity-                  "Can only configure either single component or all of them"--    let use_external_internal_deps = isJust mb_cname-    case mb_cname of-        Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0)-        Just cname -> setupMessage' verbosity "Configuring" (packageId pkg_descr0)-                        cname (Just (configInstantiateWith cfg))--    -- configCID is only valid for per-component configure-    when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $-        die' verbosity "--cid is only supported for per-component configure"--    checkDeprecatedFlags verbosity cfg-    checkExactConfiguration verbosity pkg_descr0 cfg--    -- Where to build the package-    let buildDir :: FilePath -- e.g. dist/build-        -- fromFlag OK due to Distribution.Simple calling-        -- findDistPrefOrDefault to fill it in-        buildDir = fromFlag (configDistPref cfg) </> "build"-    createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir--    -- What package database(s) to use-    let packageDbs :: PackageDBStack-        packageDbs-         = interpretPackageDbFlags-            (fromFlag (configUserInstall cfg))-            (configPackageDBs cfg)--    -- comp:            the compiler we're building with-    -- compPlatform:    the platform we're building for-    -- programDb:  location and args of all programs we're-    --                  building with-    (comp         :: Compiler,-     compPlatform :: Platform,-     programDb    :: ProgramDb)-        <- configCompilerEx-            (flagToMaybe (configHcFlavor cfg))-            (flagToMaybe (configHcPath cfg))-            (flagToMaybe (configHcPkg cfg))-            (mkProgramDb cfg (configPrograms cfg))-            (lessVerbose verbosity)--    -- The InstalledPackageIndex of all installed packages-    installedPackageSet :: InstalledPackageIndex-        <- getInstalledPackages (lessVerbose verbosity) comp-                                  packageDbs programDb--    -- The set of package names which are "shadowed" by internal-    -- packages, and which component they map to-    let internalPackageSet :: Set LibraryName-        internalPackageSet = getInternalLibraries pkg_descr0--    -- Make a data structure describing what components are enabled.-    let enabled :: ComponentRequestedSpec-        enabled = case mb_cname of-                    Just cname -> OneComponentRequestedSpec cname-                    Nothing -> ComponentRequestedSpec-                                -- The flag name (@--enable-tests@) is a-                                -- little bit of a misnomer, because-                                -- just passing this flag won't-                                -- "enable", in our internal-                                -- nomenclature; it's just a request; a-                                -- @buildable: False@ might make it-                                -- not possible to enable.-                                { testsRequested = fromFlag (configTests cfg)-                                , benchmarksRequested =-                                  fromFlag (configBenchmarks cfg) }-    -- Some sanity checks related to enabling components.-    when (isJust mb_cname-          && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg))) $-        die' verbosity $-              "--enable-tests/--enable-benchmarks are incompatible with" ++-              " explicitly specifying a component to configure."--    -- Some sanity checks related to dynamic/static linking.-    when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $-        die' verbosity $-              "--enable-executable-dynamic and --enable-executable-static" ++-              " are incompatible with each other."--    -- allConstraints:  The set of all 'Dependency's we have.  Used ONLY-    --                  to 'configureFinalizedPackage'.-    -- requiredDepsMap: A map from 'PackageName' to the specifically-    --                  required 'InstalledPackageInfo', due to --dependency-    ---    -- NB: These constraints are to be applied to ALL components of-    -- a package.  Thus, it's not an error if allConstraints contains-    -- more constraints than is necessary for a component (another-    -- component might need it.)-    ---    -- NB: The fact that we bundle all the constraints together means-    -- that is not possible to configure a test-suite to use one-    -- version of a dependency, and the executable to use another.-    (allConstraints  :: [PackageVersionConstraint],-     requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo)-        <- either (die' verbosity) return $-              combinedConstraints (configConstraints cfg)-                                  (configDependencies cfg)-                                  installedPackageSet--    -- pkg_descr:   The resolved package description, that does not contain any-    --              conditionals, because we have an assignment for-    --              every flag, either picking them ourselves using a-    --              simple naive algorithm, or having them be passed to-    --              us by 'configConfigurationsFlags')-    -- flags:       The 'FlagAssignment' that the conditionals were-    --              resolved with.-    ---    -- NB: Why doesn't finalizing a package also tell us what the-    -- dependencies are (e.g. when we run the naive algorithm,-    -- we are checking if dependencies are satisfiable)?  The-    -- primary reason is that we may NOT have done any solving:-    -- if the flags are all chosen for us, this step is a simple-    -- matter of flattening according to that assignment.  It's-    -- cleaner to then configure the dependencies afterwards.-    (pkg_descr :: PackageDescription,-     flags     :: FlagAssignment)-        <- configureFinalizedPackage verbosity cfg enabled-                allConstraints-                (dependencySatisfiable-                    use_external_internal_deps-                    (fromFlagOrDefault False (configExactConfiguration cfg))-                    (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg))-                    (packageName pkg_descr0)-                    installedPackageSet-                    internalPackageSet-                    requiredDepsMap)-                comp-                compPlatform-                pkg_descr0--    debug verbosity $ "Finalized package description:\n"-                  ++ showPackageDescription pkg_descr--    let cabalFileDir = maybe "." takeDirectory $-          flagToMaybe (configCabalFilePath cfg)-    checkCompilerProblems verbosity comp pkg_descr enabled-    checkPackageProblems verbosity cabalFileDir pkg_descr0-        (updatePackageDescription pbi pkg_descr)--    -- The list of 'InstalledPackageInfo' recording the selected-    -- dependencies on external packages.-    ---    -- Invariant: For any package name, there is at most one package-    -- in externalPackageDeps which has that name.-    ---    -- NB: The dependency selection is global over ALL components-    -- in the package (similar to how allConstraints and-    -- requiredDepsMap are global over all components).  In particular,-    -- if *any* component (post-flag resolution) has an unsatisfiable-    -- dependency, we will fail.  This can sometimes be undesirable-    -- for users, see #1786 (benchmark conflicts with executable),-    ---    -- In the presence of Backpack, these package dependencies are-    -- NOT complete: they only ever include the INDEFINITE-    -- dependencies.  After we apply an instantiation, we'll get-    -- definite references which constitute extra dependencies.-    -- (Why not have cabal-install pass these in explicitly?-    -- For one it's deterministic; for two, we need to associate-    -- them with renamings which would require a far more complicated-    -- input scheme than what we have today.)-    externalPkgDeps :: [PreExistingComponent]-        <- configureDependencies-                verbosity-                use_external_internal_deps-                internalPackageSet-                installedPackageSet-                requiredDepsMap-                pkg_descr-                enabled--    -- Compute installation directory templates, based on user-    -- configuration.-    ---    -- TODO: Move this into a helper function.-    defaultDirs :: InstallDirTemplates-        <- defaultInstallDirs' use_external_internal_deps-                              (compilerFlavor comp)-                              (fromFlag (configUserInstall cfg))-                              (hasLibs pkg_descr)-    let installDirs :: InstallDirTemplates-        installDirs = combineInstallDirs fromFlagOrDefault-                        defaultDirs (configInstallDirs cfg)--    -- Check languages and extensions-    -- TODO: Move this into a helper function.-    let langlist = nub $ catMaybes $ map defaultLanguage-                   (enabledBuildInfos pkg_descr enabled)-    let langs = unsupportedLanguages comp langlist-    when (not (null langs)) $-      die' verbosity $ "The package " ++ prettyShow (packageId pkg_descr0)-         ++ " requires the following languages which are not "-         ++ "supported by " ++ prettyShow (compilerId comp) ++ ": "-         ++ intercalate ", " (map prettyShow langs)-    let extlist = nub $ concatMap allExtensions-                  (enabledBuildInfos pkg_descr enabled)-    let exts = unsupportedExtensions comp extlist-    when (not (null exts)) $-      die' verbosity $ "The package " ++ prettyShow (packageId pkg_descr0)-         ++ " requires the following language extensions which are not "-         ++ "supported by " ++ prettyShow (compilerId comp) ++ ": "-         ++ intercalate ", " (map prettyShow exts)--    -- Check foreign library build requirements-    let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled]-    let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs-    when (not (null unsupportedFLibs)) $-      die' verbosity $ "Cannot build some foreign libraries: "-         ++ intercalate "," unsupportedFLibs--    -- Configure certain external build tools, see below for which ones.-    let requiredBuildTools = do-          bi <- enabledBuildInfos pkg_descr enabled-          -- First, we collect any tool dep that we know is external. This is,-          -- in practice:-          ---          -- 1. `build-tools` entries on the whitelist-          ---          -- 2. `build-tool-depends` that aren't from the current package.-          let externBuildToolDeps =-                [ LegacyExeDependency (unUnqualComponentName eName) versionRange-                | buildTool@(ExeDependency _ eName versionRange)-                  <- getAllToolDependencies pkg_descr bi-                , not $ isInternal pkg_descr buildTool ]-          -- Second, we collect any build-tools entry we don't know how to-          -- desugar. We'll never have any idea how to build them, so we just-          -- hope they are already on the PATH.-          let unknownBuildTools =-                [ buildTool-                | buildTool <- buildTools bi-                , Nothing == desugarBuildTool pkg_descr buildTool ]-          externBuildToolDeps ++ unknownBuildTools--    programDb' <--          configureAllKnownPrograms (lessVerbose verbosity) programDb-      >>= configureRequiredPrograms verbosity requiredBuildTools--    (pkg_descr', programDb'') <--      configurePkgconfigPackages verbosity pkg_descr programDb' enabled--    -- Compute internal component graph-    ---    -- The general idea is that we take a look at all the source level-    -- components (which may build-depends on each other) and form a graph.-    -- From there, we build a ComponentLocalBuildInfo for each of the-    -- components, which lets us actually build each component.-    -- internalPackageSet-    -- use_external_internal_deps-    (buildComponents :: [ComponentLocalBuildInfo],-     packageDependsIndex :: InstalledPackageIndex) <--      runLogProgress verbosity $ configureComponentLocalBuildInfos-            verbosity-            use_external_internal_deps-            enabled-            (fromFlagOrDefault False (configDeterministic cfg))-            (configIPID cfg)-            (configCID cfg)-            pkg_descr-            externalPkgDeps-            (configConfigurationsFlags cfg)-            (configInstantiateWith cfg)-            installedPackageSet-            comp--    -- Decide if we're going to compile with split sections.-    split_sections :: Bool <--       if not (fromFlag $ configSplitSections cfg)-            then return False-            else case compilerFlavor comp of-                        GHC | compilerVersion comp >= mkVersion [8,0]-                          -> return True-                        GHCJS-                          -> return True-                        _ -> do warn verbosity-                                     ("this compiler does not support " ++-                                      "--enable-split-sections; ignoring")-                                return False--    -- Decide if we're going to compile with split objects.-    split_objs :: Bool <--       if not (fromFlag $ configSplitObjs cfg)-            then return False-            else case compilerFlavor comp of-                        _ | split_sections-                          -> do warn verbosity-                                     ("--enable-split-sections and " ++-                                      "--enable-split-objs are mutually" ++-                                      "exclusive; ignoring the latter")-                                return False-                        GHC-                          -> return True-                        GHCJS-                          -> return True-                        _ -> do warn verbosity-                                     ("this compiler does not support " ++-                                      "--enable-split-objs; ignoring")-                                return False--    let ghciLibByDefault =-          case compilerId comp of-            CompilerId GHC _ ->-              -- If ghc is non-dynamic, then ghci needs object files,-              -- so we build one by default.-              ---              -- Technically, archive files should be sufficient for ghci,-              -- but because of GHC bug #8942, it has never been safe to-              -- rely on them. By the time that bug was fixed, ghci had-              -- been changed to read shared libraries instead of archive-              -- files (see next code block).-              not (GHC.isDynamic comp)-            CompilerId GHCJS _ ->-              not (GHCJS.isDynamic comp)-            _ -> False--    let sharedLibsByDefault-          | fromFlag (configDynExe cfg) =-              -- build a shared library if dynamically-linked-              -- executables are requested-              True-          | otherwise = case compilerId comp of-            CompilerId GHC _ ->-              -- if ghc is dynamic, then ghci needs a shared-              -- library, so we build one by default.-              GHC.isDynamic comp-            CompilerId GHCJS _ ->-              GHCJS.isDynamic comp-            _ -> False-        withSharedLib_ =-            -- build shared libraries if required by GHC or by the-            -- executable linking mode, but allow the user to force-            -- building only static library archives with-            -- --disable-shared.-            fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg--        withStaticLib_ =-            -- build a static library (all dependent libraries rolled-            -- into a huge .a archive) via GHCs -staticlib flag.-            fromFlagOrDefault False $ configStaticLib cfg--        withDynExe_ = fromFlag $ configDynExe cfg--        withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg-    when (withDynExe_ && not withSharedLib_) $ warn verbosity $-           "Executables will use dynamic linking, but a shared library "-        ++ "is not being built. Linking will fail if any executables "-        ++ "depend on the library."--    setProfLBI <- configureProfiling verbosity cfg comp--    setCoverageLBI <- configureCoverage verbosity cfg comp----    -- Turn off library and executable stripping when `debug-info` is set-    -- to anything other than zero.-    let-        strip_libexe s f =-          let defaultStrip = fromFlagOrDefault True (f cfg)-          in case fromFlag (configDebugInfo cfg) of-                      NoDebugInfo -> return defaultStrip-                      _ -> case f cfg of-                             Flag True -> do-                              warn verbosity $ "Setting debug-info implies "-                                                ++ s ++ "-stripping: False"-                              return False--                             _ -> return False--    strip_lib <- strip_libexe "library" configStripLibs-    strip_exe <- strip_libexe "executable" configStripExes---    let reloc = fromFlagOrDefault False $ configRelocatable cfg--    let buildComponentsMap =-            foldl' (\m clbi -> Map.insertWith (++)-                               (componentLocalName clbi) [clbi] m)-                   Map.empty buildComponents--    let lbi = (setCoverageLBI . setProfLBI)-              LocalBuildInfo {-                configFlags         = cfg,-                flagAssignment      = flags,-                componentEnabledSpec = enabled,-                extraConfigArgs     = [],  -- Currently configure does not-                                           -- take extra args, but if it-                                           -- did they would go here.-                installDirTemplates = installDirs,-                compiler            = comp,-                hostPlatform        = compPlatform,-                buildDir            = buildDir,-                cabalFilePath       = flagToMaybe (configCabalFilePath cfg),-                componentGraph      = Graph.fromDistinctList buildComponents,-                componentNameMap    = buildComponentsMap,-                installedPkgs       = packageDependsIndex,-                pkgDescrFile        = Nothing,-                localPkgDescr       = pkg_descr',-                withPrograms        = programDb'',-                withVanillaLib      = fromFlag $ configVanillaLib cfg,-                withSharedLib       = withSharedLib_,-                withStaticLib       = withStaticLib_,-                withDynExe          = withDynExe_,-                withFullyStaticExe  = withFullyStaticExe_,-                withProfLib         = False,-                withProfLibDetail   = ProfDetailNone,-                withProfExe         = False,-                withProfExeDetail   = ProfDetailNone,-                withOptimization    = fromFlag $ configOptimization cfg,-                withDebugInfo       = fromFlag $ configDebugInfo cfg,-                withGHCiLib         = fromFlagOrDefault ghciLibByDefault $-                                      configGHCiLib cfg,-                splitSections       = split_sections,-                splitObjs           = split_objs,-                stripExes           = strip_exe,-                stripLibs           = strip_lib,-                exeCoverage         = False,-                libCoverage         = False,-                withPackageDB       = packageDbs,-                progPrefix          = fromFlag $ configProgPrefix cfg,-                progSuffix          = fromFlag $ configProgSuffix cfg,-                relocatable         = reloc-              }--    when reloc (checkRelocatable verbosity pkg_descr lbi)--    -- TODO: This is not entirely correct, because the dirs may vary-    -- across libraries/executables-    let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest-        relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi--    -- PKGROOT: allowing ${pkgroot} to be passed as --prefix to-    -- cabal configure, is only a hidden option. It allows packages-    -- to be relocatable with their package database.  This however-    -- breaks when the Paths_* or other includes are used that-    -- contain hard coded paths. This is still an open TODO.-    ---    -- Allowing ${pkgroot} here, however requires less custom hooks-    -- in scripts that *really* want ${pkgroot}. See haskell/cabal/#4872-    unless (isAbsolute (prefix dirs)-           || "${pkgroot}" `isPrefixOf` prefix dirs) $ die' verbosity $-        "expected an absolute directory name for --prefix: " ++ prefix dirs--    when ("${pkgroot}" `isPrefixOf` prefix dirs) $-      warn verbosity $ "Using ${pkgroot} in prefix " ++ prefix dirs-                    ++ " will not work if you rely on the Path_* module "-                    ++ " or other hard coded paths.  Cabal does not yet "-                    ++ " support fully  relocatable builds! "-                    ++ " See #462 #2302 #2994 #3305 #3473 #3586 #3909"-                    ++ " #4097 #4291 #4872"--    info verbosity $ "Using " ++ prettyShow currentCabalId-                  ++ " compiled by " ++ prettyShow currentCompilerId-    info verbosity $ "Using compiler: " ++ showCompilerId comp-    info verbosity $ "Using install prefix: " ++ prefix dirs--    let dirinfo name dir isPrefixRelative =-          info verbosity $ name ++ " installed in: " ++ dir ++ relNote-          where relNote = case buildOS of-                  Windows | not (hasLibs pkg_descr)-                         && isNothing isPrefixRelative-                         -> "  (fixed location)"-                  _      -> ""--    dirinfo "Executables"      (bindir dirs)     (bindir relative)-    dirinfo "Libraries"        (libdir dirs)     (libdir relative)-    dirinfo "Dynamic Libraries" (dynlibdir dirs) (dynlibdir relative)-    dirinfo "Private executables" (libexecdir dirs) (libexecdir relative)-    dirinfo "Data files"       (datadir dirs)    (datadir relative)-    dirinfo "Documentation"    (docdir dirs)     (docdir relative)-    dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative)--    sequence_ [ reportProgram verbosity prog configuredProg-              | (prog, configuredProg) <- knownPrograms programDb'' ]--    return lbi--    where-      verbosity = fromFlag (configVerbosity cfg)--mkProgramDb :: ConfigFlags -> ProgramDb -> ProgramDb-mkProgramDb cfg initialProgramDb = programDb-  where-    programDb  = userSpecifyArgss (configProgramArgs cfg)-                 . userSpecifyPaths (configProgramPaths cfg)-                 . setProgramSearchPath searchpath-                 $ initialProgramDb-    searchpath = getProgramSearchPath initialProgramDb-                 ++ map ProgramSearchPathDir-                 (fromNubList $ configProgramPathExtra cfg)---- -------------------------------------------------------------------------------- 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) $-        die' verbosity $ "'--exact-configuration' was given, "-        ++ "but the following flags were not specified: "-        ++ intercalate ", " (map show diffFlags)---- | Create a PackageIndex that makes *any libraries that might be*--- defined internally to this package look like installed packages, in--- 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) InstalledPackageInfo-       -- ^ required dependencies-    -> (Dependency -> Bool)-dependencySatisfiable-  use_external_internal_deps-  exact_config-  allow_private_deps-  pn installedPackageSet packageLibraries requiredDepsMap-  (Dependency depName vr sublibs)-    | exact_config-    -- When we're given '--exact-configuration', we assume that all-    -- dependencies and flags are exactly specified on the command-    -- line. Thus we only consult the 'requiredDepsMap'. Note that-    -- we're not doing the version range check, so if there's some-    -- dependency that wasn't specified on the command line,-    -- 'finalizePD' will fail.-    -- TODO: mention '--exact-configuration' in the error message-    -- when this fails?-    = if isInternalDep && not use_external_internal_deps-        -- Except for internal deps, when we're NOT per-component mode;-        -- those are just True.-        then internalDepSatisfiable-        else-          -- Backward compatibility for the old sublibrary syntax-          (sublibs == mainLibSet-            && Map.member-                 (pn, CLibName $ LSubLibName $-                      packageNameToUnqualComponentName depName)-                 requiredDepsMap)--          || all visible sublibs--    | isInternalDep-    = if use_external_internal_deps-        -- When we are doing per-component configure, we now need to-        -- test if the internal dependency is in the index.  This has-        -- DIFFERENT semantics from normal dependency satisfiability.-        then internalDepSatisfiableExternally-        -- If a 'PackageName' is defined by an internal component, the dep is-        -- satisfiable (we're going to build it ourselves)-        else internalDepSatisfiable--    | otherwise-    = depSatisfiable--  where-    -- Internal dependency is when dependency is the same as package.-    isInternalDep = pn == depName--    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-      where maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap---- | Finalize a generic package description.  The workhorse is--- 'finalizePD' but there's a bit of other nattering--- about necessary.------ TODO: what exactly is the business with @flaggedTests@ and--- @flaggedBenchmarks@?-configureFinalizedPackage-    :: Verbosity-    -> ConfigFlags-    -> ComponentRequestedSpec-    -> [PackageVersionConstraint]-    -> (Dependency -> Bool) -- ^ tests if a dependency is satisfiable.-                            -- Might say it's satisfiable even when not.-    -> Compiler-    -> Platform-    -> GenericPackageDescription-    -> IO (PackageDescription, FlagAssignment)-configureFinalizedPackage verbosity cfg enabled-  allConstraints satisfies comp compPlatform pkg_descr0 = do--    (pkg_descr0', flags) <--            case finalizePD-                   (configConfigurationsFlags cfg)-                   enabled-                   satisfies-                   compPlatform-                   (compilerInfo comp)-                   allConstraints-                   pkg_descr0-            of Right r -> return r-               Left missing ->-                   die' verbosity $ "Encountered missing or private dependencies:\n"-                     ++ (render . nest 4 . sep . punctuate comma-                                . map (pretty . simplifyDependency)-                                $ missing)--    -- add extra include/lib dirs as specified in cfg-    -- we do it here so that those get checked too-    let pkg_descr = addExtraIncludeLibDirs pkg_descr0'--    unless (nullFlagAssignment flags) $-      info verbosity $ "Flags chosen: "-                    ++ intercalate ", " [ unFlagName fn ++ "=" ++ prettyShow value-                                        | (fn, value) <- unFlagAssignment flags ]--    return (pkg_descr, flags)-  where-    addExtraIncludeLibDirs pkg_descr =-        let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg-                             , extraFrameworkDirs = configExtraFrameworkDirs cfg-                             , includeDirs = configExtraIncludeDirs cfg}-            modifyLib l        = l{ libBuildInfo        = libBuildInfo l-                                                          `mappend` extraBi }-            modifyExecutable e = e{ buildInfo           = buildInfo e-                                                          `mappend` extraBi}-            modifyForeignLib f = f{ foreignLibBuildInfo = foreignLibBuildInfo f-                                                          `mappend` extraBi}-            modifyTestsuite  t = t{ testBuildInfo      = testBuildInfo t-                                                          `mappend` extraBi}-            modifyBenchmark  b = b{ benchmarkBuildInfo  = benchmarkBuildInfo b-                                                          `mappend` extraBi}-        in pkg_descr-             { library      = modifyLib        `fmap` library      pkg_descr-             , subLibraries = modifyLib        `map`  subLibraries pkg_descr-             , executables  = modifyExecutable `map`  executables  pkg_descr-             , foreignLibs  = modifyForeignLib `map`  foreignLibs  pkg_descr-             , testSuites   = modifyTestsuite  `map`  testSuites   pkg_descr-             , benchmarks   = modifyBenchmark  `map`  benchmarks   pkg_descr-             }---- | Check for use of Cabal features which require compiler support-checkCompilerProblems-  :: Verbosity -> Compiler -> PackageDescription -> ComponentRequestedSpec -> IO ()-checkCompilerProblems verbosity comp pkg_descr enabled = do-    unless (renamingPackageFlagsSupported comp ||-             all (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins)-                         (enabledBuildInfos pkg_descr enabled)) $-        die' verbosity $-              "Your compiler does not support thinning and renaming on "-           ++ "package flags.  To use this feature you must use "-           ++ "GHC 7.9 or later."--    when (any (not.null.reexportedModules) (allLibraries pkg_descr)-          && not (reexportedModulesSupported comp)) $-        die' verbosity $-             "Your compiler does not support module re-exports. To use "-          ++ "this feature you must use GHC 7.9 or later."--    when (any (not.null.signatures) (allLibraries pkg_descr)-          && not (backpackSupported comp)) $-        die' verbosity $-               "Your compiler does not support Backpack. To use "-           ++ "this feature you must use GHC 8.1 or later."---- | Select dependencies for the package.-configureDependencies-    :: Verbosity-    -> UseExternalInternalDeps-    -> Set LibraryName-    -> InstalledPackageIndex -- ^ installed packages-    -> Map (PackageName, ComponentName) InstalledPackageInfo -- ^ required deps-    -> PackageDescription-    -> ComponentRequestedSpec-    -> IO [PreExistingComponent]-configureDependencies verbosity use_external_internal_deps-  packageLibraries installedPackageSet requiredDepsMap pkg_descr enableSpec = do-    let failedDeps :: [FailedDependency]-        allPkgDeps :: [ResolvedDependency]-        (failedDeps, allPkgDeps) = partitionEithers $ concat-          [ fmap (\s -> (dep, s)) <$> status-          | dep <- enabledBuildDepends pkg_descr enableSpec-          , let status = selectDependency (package pkg_descr)-                  packageLibraries installedPackageSet-                  requiredDepsMap use_external_internal_deps dep ]--        internalPkgDeps = [ pkgid-                          | (_, InternalDependency pkgid) <- allPkgDeps ]-        -- 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 ]--    when (not (null internalPkgDeps)-          && not (newPackageDepsBehaviour pkg_descr)) $-        die' verbosity $ "The field 'build-depends: "-           ++ intercalate ", " (map (prettyShow . packageName) internalPkgDeps)-           ++ "' refers to a library which is defined within the same "-           ++ "package. To use this feature the package must specify at "-           ++ "least 'cabal-version: >= 1.8'."--    reportFailedDependencies verbosity failedDeps-    reportSelectedDependencies verbosity allPkgDeps--    return externalPkgDeps---- | Select and apply coverage settings for the build based on the--- 'ConfigFlags' and 'Compiler'.-configureCoverage :: Verbosity -> ConfigFlags -> Compiler-                  -> IO (LocalBuildInfo -> LocalBuildInfo)-configureCoverage verbosity cfg comp = do-    let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg)-        tryLibCoverage = fromFlagOrDefault tryExeCoverage-                         (mappend (configCoverage cfg) (configLibCoverage cfg))-    if coverageSupported comp-      then do-        let apply lbi = lbi { libCoverage = tryLibCoverage-                            , exeCoverage = tryExeCoverage-                            }-        return apply-      else do-        let apply lbi = lbi { libCoverage = False-                            , exeCoverage = False-                            }-        when (tryExeCoverage || tryLibCoverage) $ warn verbosity-          ("The compiler " ++ showCompilerId comp ++ " does not support "-           ++ "program coverage. Program coverage has been disabled.")-        return apply---- | Compute the effective value of the profiling flags--- @--enable-library-profiling@ and @--enable-executable-profiling@--- from the specified 'ConfigFlags'.  This may be useful for--- external Cabal tools which need to interact with Setup in--- a backwards-compatible way: the most predictable mechanism--- for enabling profiling across many legacy versions is to--- NOT use @--enable-profiling@ and use those two flags instead.------ Note that @--enable-executable-profiling@ also affects profiling--- of benchmarks and (non-detailed) test suites.-computeEffectiveProfiling :: ConfigFlags -> (Bool {- lib -}, Bool {- exe -})-computeEffectiveProfiling cfg =-  -- The --profiling flag sets the default for both libs and exes,-  -- but can be overidden by --library-profiling, or the old deprecated-  -- --executable-profiling flag.-  ---  -- The --profiling-detail and --library-profiling-detail flags behave-  -- similarly-  let tryExeProfiling = fromFlagOrDefault False-                        (mappend (configProf cfg) (configProfExe cfg))-      tryLibProfiling = fromFlagOrDefault tryExeProfiling-                        (mappend (configProf cfg) (configProfLib cfg))-  in (tryLibProfiling, tryExeProfiling)---- | Select and apply profiling settings for the build based on the--- 'ConfigFlags' and 'Compiler'.-configureProfiling :: Verbosity -> ConfigFlags -> Compiler-                   -> IO (LocalBuildInfo -> LocalBuildInfo)-configureProfiling verbosity cfg comp = do-  let (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling cfg--      tryExeProfileLevel = fromFlagOrDefault ProfDetailDefault-                           (configProfDetail cfg)-      tryLibProfileLevel = fromFlagOrDefault ProfDetailDefault-                           (mappend-                            (configProfDetail cfg)-                            (configProfLibDetail cfg))--      checkProfileLevel (ProfDetailOther other) = do-        warn verbosity-          ("Unknown profiling detail level '" ++ other-           ++ "', using default.\nThe profiling detail levels are: "-           ++ intercalate ", "-           [ name | (name, _, _) <- knownProfDetailLevels ])-        return ProfDetailDefault-      checkProfileLevel other = return other--  (exeProfWithoutLibProf, applyProfiling) <--    if profilingSupported comp-    then do-      exeLevel <- checkProfileLevel tryExeProfileLevel-      libLevel <- checkProfileLevel tryLibProfileLevel-      let apply lbi = lbi { withProfLib       = tryLibProfiling-                          , withProfLibDetail = libLevel-                          , withProfExe       = tryExeProfiling-                          , withProfExeDetail = exeLevel-                          }-      return (tryExeProfiling && not tryLibProfiling, apply)-    else do-      let apply lbi = lbi { withProfLib = False-                          , withProfLibDetail = ProfDetailNone-                          , withProfExe = False-                          , withProfExeDetail = ProfDetailNone-                          }-      when (tryExeProfiling || tryLibProfiling) $ warn verbosity-        ("The compiler " ++ showCompilerId comp ++ " does not support "-         ++ "profiling. Profiling has been disabled.")-      return (False, apply)--  when exeProfWithoutLibProf $ warn verbosity-    ("Executables will be built with profiling, but library "-     ++ "profiling is disabled. Linking will fail if any executables "-     ++ "depend on the library.")--  return applyProfiling---- -------------------------------------------------------------------------------- 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-    -- | An internal dependency ('PackageId' should be a library name)-    -- which we are going to have to build.  (The-    -- 'PackageId' here is a hack to get a modest amount of-    -- polymorphism out of the 'Package' typeclass.)-    | InternalDependency PackageId--data FailedDependency = DependencyNotExists PackageName-                      | DependencyMissingInternal PackageName LibraryName-                      | DependencyNoVersion Dependency---- | Test for a package dependency and record the version we have installed.-selectDependency :: PackageId -- ^ Package id of current package-                 -> Set LibraryName -- ^ package libraries-                 -> InstalledPackageIndex  -- ^ Installed packages-                 -> Map (PackageName, ComponentName) InstalledPackageInfo-                    -- ^ Packages for which we have been given specific deps to-                    -- use-                 -> UseExternalInternalDeps -- ^ Are we configuring a-                                            -- single component?-                 -> Dependency-                 -> [Either FailedDependency DependencyResolution]-selectDependency pkgid internalIndex installedIndex requiredDepsMap-  use_external_internal_deps-  (Dependency dep_pkgname vr libs) =-  -- If the dependency specification matches anything in the internal package-  -- index, then we prefer that match to anything in the second.-  -- For example:-  ---  -- Name: MyLibrary-  -- Version: 0.1-  -- Library-  --     ..-  -- Executable my-exec-  --     build-depends: MyLibrary-  ---  -- We want "build-depends: MyLibrary" always to match the internal library-  -- even if there is a newer installed library "MyLibrary-0.2".-  if dep_pkgname == pn-  then-      if use_external_internal_deps-      then do_external_internal <$> NES.toList libs-      else do_internal <$> NES.toList libs-  else-      do_external_external <$> NES.toList libs-  where-    pn = packageName pkgid--    -- It's an internal library, and we're not per-component build-    do_internal lib-        | Set.member lib internalIndex-        = Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid--        | otherwise-        = Left $ DependencyMissingInternal dep_pkgname lib--    -- We have to look it up externally-    do_external_external :: LibraryName -> Either FailedDependency DependencyResolution-    do_external_external lib = do-      ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of-        -- If we know the exact pkg to use, then use it.-        Just pkginstance -> Right pkginstance-        -- Otherwise we just pick an arbitrary instance of the latest version.-        Nothing -> case pickLastIPI $ PackageIndex.lookupDependency installedIndex dep_pkgname vr of-          Nothing  -> Left (DependencyNotExists dep_pkgname)-          Just pkg -> Right pkg-      return $ ExternalDependency $ ipiToPreExistingComponent ipi--    do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution-    do_external_internal lib = do-      ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of-        -- If we know the exact pkg to use, then use it.-        Just pkginstance -> Right pkginstance-        Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex pn vr lib of-          -- It's an internal library, being looked up externally-          Nothing  -> Left (DependencyMissingInternal dep_pkgname lib)-          Just pkg -> Right pkg-      return $ ExternalDependency $ ipiToPreExistingComponent ipi--    pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo-    pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs--reportSelectedDependencies :: Verbosity-                           -> [ResolvedDependency] -> IO ()-reportSelectedDependencies verbosity deps =-  info verbosity $ unlines-    [ "Dependency " ++ prettyShow (simplifyDependency dep)-                    ++ ": using " ++ prettyShow pkgid-    | (dep, resolution) <- deps-    , let pkgid = case resolution of-            ExternalDependency pkg'   -> packageId pkg'-            InternalDependency pkgid' -> pkgid' ]--reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO ()-reportFailedDependencies _ []     = return ()-reportFailedDependencies verbosity failed =-    die' verbosity (intercalate "\n\n" (map reportFailedDependency failed))--  where-    reportFailedDependency (DependencyNotExists pkgname) =-         "there is no version of " ++ prettyShow pkgname ++ " installed.\n"-      ++ "Perhaps you need to download and install it from\n"-      ++ hackageUrl ++ prettyShow pkgname ++ "?"--    reportFailedDependency (DependencyMissingInternal pkgname lib) =-         "internal dependency " ++ prettyShow (prettyLibraryNameComponent lib) ++ " not installed.\n"-      ++ "Perhaps you need to configure and install it first?\n"-      ++ "(This library was defined by " ++ prettyShow pkgname ++ ")"--    reportFailedDependency (DependencyNoVersion dep) =-        "cannot satisfy dependency " ++ prettyShow (simplifyDependency dep) ++ "\n"---- | List all installed packages in the given package databases.--- Non-existent package databases do not cause errors, they just get skipped--- with a warning and treated as empty ones, since technically they do not--- contain any package.-getInstalledPackages :: Verbosity -> Compiler-                     -> PackageDBStack -- ^ The stack of package databases.-                     -> ProgramDb-                     -> IO InstalledPackageIndex-getInstalledPackages verbosity comp packageDBs progdb = do-  when (null packageDBs) $-    die' verbosity $ "No package databases have been specified. If you use "-       ++ "--package-db=clear, you must follow it with --package-db= "-       ++ "with 'global', 'user' or a specific file."--  info verbosity "Reading installed packages..."-  -- do not check empty packagedbs (ghc-pkg would error out)-  packageDBs' <- filterM packageDBExists packageDBs-  case compilerFlavor comp of-    GHC   -> GHC.getInstalledPackages verbosity comp packageDBs' progdb-    GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs' progdb-    UHC   -> UHC.getInstalledPackages verbosity comp packageDBs' progdb-    HaskellSuite {} ->-      HaskellSuite.getInstalledPackages verbosity packageDBs' progdb-    flv -> die' verbosity $ "don't know how to find the installed packages for "-              ++ prettyShow flv-  where-    packageDBExists (SpecificPackageDB path) = do-      exists <- doesPathExist path-      unless exists $-        warn verbosity $ "Package db " <> path <> " does not exist yet"-      return exists-    -- Checking the user and global package dbs is more complicated and needs-    -- way more data. Also ghc-pkg won't error out unless the user/global-    -- pkgdb is overridden with an empty one, so we just don't check for them.-    packageDBExists UserPackageDB            = pure True-    packageDBExists GlobalPackageDB          = pure True---- | Like 'getInstalledPackages', but for a single package DB.------ NB: Why isn't this always a fall through to 'getInstalledPackages'?--- That is because 'getInstalledPackages' performs some sanity checks--- on the package database stack in question.  However, when sandboxes--- are involved these sanity checks are not desirable.-getPackageDBContents :: Verbosity -> Compiler-                     -> PackageDB -> ProgramDb-                     -> IO InstalledPackageIndex-getPackageDBContents verbosity comp packageDB progdb = do-  info verbosity "Reading installed packages..."-  case compilerFlavor comp of-    GHC -> GHC.getPackageDBContents verbosity packageDB progdb-    GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progdb-    -- For other compilers, try to fall back on 'getInstalledPackages'.-    _   -> getInstalledPackages verbosity comp [packageDB] progdb----- | A set of files (or directories) that can be monitored to detect when--- there might have been a change in the installed packages.----getInstalledPackagesMonitorFiles :: Verbosity -> Compiler-                                 -> PackageDBStack-                                 -> ProgramDb -> Platform-                                 -> IO [FilePath]-getInstalledPackagesMonitorFiles verbosity comp packageDBs progdb platform =-  case compilerFlavor comp of-    GHC   -> GHC.getInstalledPackagesMonitorFiles-               verbosity platform progdb packageDBs-    other -> do-      warn verbosity $ "don't know how to find change monitoring files for "-                    ++ "the installed package databases for " ++ prettyShow other-      return []---- | The user interface specifies the package dbs to use with a combination of--- @--global@, @--user@ and @--package-db=global|user|clear|$file@.--- This function combines the global/user flag and interprets the package-db--- flag into a single package db stack.----interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack-interpretPackageDbFlags userInstall specificDBs =-    extra initialStack specificDBs-  where-    initialStack | userInstall = [GlobalPackageDB, UserPackageDB]-                 | otherwise   = [GlobalPackageDB]--    extra dbs' []            = dbs'-    extra _    (Nothing:dbs) = extra []             dbs-    extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs---- We are given both --constraint="foo < 2.0" style constraints and also--- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581".------ When finalising the package we have to take into account the specific--- installed deps we've been given, and the finalise function expects--- constraints, so we have to translate these deps into version constraints.------ But after finalising we then have to make sure we pick the right specific--- deps in the end. So we still need to remember which installed packages to--- pick.-combinedConstraints-  :: [PackageVersionConstraint]-  -> [GivenComponent]-  -> InstalledPackageIndex-  -> Either String ([PackageVersionConstraint],-                     Map (PackageName, ComponentName) InstalledPackageInfo)-combinedConstraints constraints dependencies installedPackages = do--    when (not (null badComponentIds)) $-      Left $ render $ text "The following package dependencies were requested"-         $+$ nest 4 (dispDependencies badComponentIds)-         $+$ text "however the given installed package instance does not exist."--    --TODO: we don't check that all dependencies are used!--    return (allConstraints, idConstraintMap)--  where-    allConstraints :: [PackageVersionConstraint]-    allConstraints = constraints-                  ++ [ thisPackageVersionConstraint (packageId pkg)-                     | (_, _, _, Just pkg) <- dependenciesPkgInfo ]--    idConstraintMap :: Map (PackageName, ComponentName) InstalledPackageInfo-    idConstraintMap = Map.fromList-                        -- NB: do NOT use the packageName from-                        -- dependenciesPkgInfo!-                        [ ((pn, cname), pkg)-                        | (pn, cname, _, Just pkg) <- dependenciesPkgInfo ]--    -- The dependencies along with the installed package info, if it exists-    dependenciesPkgInfo :: [(PackageName, ComponentName, ComponentId,-                             Maybe InstalledPackageInfo)]-    dependenciesPkgInfo =-      [ (pkgname, CLibName lname, cid, mpkg)-      | GivenComponent pkgname lname cid <- dependencies-      , let mpkg = PackageIndex.lookupComponentId-                     installedPackages cid-      ]--    -- If we looked up a package specified by an installed package id-    -- (i.e. someone has written a hash) and didn't find it then it's-    -- an error.-    badComponentIds =-      [ (pkgname, cname, cid)-      | (pkgname, cname, cid, Nothing) <- dependenciesPkgInfo ]--    dispDependencies deps =-      hsep [      text "--dependency="-             <<>> quotes-                    (pretty pkgname-                     <<>> case cname of-                            CLibName LMainLibName    -> ""-                            CLibName (LSubLibName n) -> ":" <<>> pretty n-                            _                        -> ":" <<>> pretty cname-                     <<>> char '='-                     <<>> pretty cid)-           | (pkgname, cname, cid) <- deps ]---- -------------------------------------------------------------------------------- Configuring program dependencies--configureRequiredPrograms :: Verbosity -> [LegacyExeDependency] -> ProgramDb-                             -> IO ProgramDb-configureRequiredPrograms verbosity deps progdb =-  foldM (configureRequiredProgram verbosity) progdb deps---- | Configure a required program, ensuring that it exists in the PATH--- (or where the user has specified the program must live) and making it--- available for use via the 'ProgramDb' interface.  If the program is--- known (exists in the input 'ProgramDb'), we will make sure that the--- program matches the required version; otherwise we will accept--- any version of the program and assume that it is a simpleProgram.-configureRequiredProgram :: Verbosity -> ProgramDb -> LegacyExeDependency-                            -> IO ProgramDb-configureRequiredProgram verbosity progdb-  (LegacyExeDependency progName verRange) =-  case lookupKnownProgram progName progdb of-    Nothing ->-      -- Try to configure it as a 'simpleProgram' automatically-      ---      -- There's a bit of a story behind this line.  In old versions-      -- of Cabal, there were only internal build-tools dependencies.  So the-      -- behavior in this case was:-      ---      --    - If a build-tool dependency was internal, don't do-      --      any checking.-      ---      --    - If it was external, call 'configureRequiredProgram' to-      --      "configure" the executable.  In particular, if-      --      the program was not "known" (present in 'ProgramDb'),-      --      then we would just error.  This was fine, because-      --      the only way a program could be executed from 'ProgramDb'-      --      is if some library code from Cabal actually called it,-      --      and the pre-existing Cabal code only calls known-      --      programs from 'defaultProgramDb', and so if it-      --      is calling something else, you have a Custom setup-      --      script, and in that case you are expected to register-      --      the program you want to call in the ProgramDb.-      ---      -- OK, so that was fine, until I (ezyang, in 2016) refactored-      -- Cabal to support per-component builds.  In this case, what-      -- was previously an internal build-tool dependency now became-      -- an external one, and now previously "internal" dependencies-      -- are now external.  But these are permitted to exist even-      -- when they are not previously configured (something that-      -- can only occur by a Custom script.)-      ---      -- So, I decided, "Fine, let's just accept these in any-      -- case."  Thus this line.  The alternative would have been to-      -- somehow detect when a build-tools dependency was "internal" (by-      -- looking at the unflattened package description) but this-      -- would also be incompatible with future work to support-      -- external executable dependencies: we definitely cannot-      -- assume they will be preinitialized in the 'ProgramDb'.-      configureProgram verbosity (simpleProgram progName) progdb-    Just prog-      -- requireProgramVersion always requires the program have a version-      -- but if the user says "build-depends: foo" ie no version constraint-      -- then we should not fail if we cannot discover the program version.-      | verRange == anyVersion -> do-          (_, progdb') <- requireProgram verbosity prog progdb-          return progdb'-      | otherwise -> do-          (_, _, progdb') <- requireProgramVersion verbosity prog verRange progdb-          return progdb'---- -------------------------------------------------------------------------------- Configuring pkg-config package dependencies--configurePkgconfigPackages :: Verbosity -> PackageDescription-                           -> ProgramDb -> ComponentRequestedSpec-                           -> IO (PackageDescription, ProgramDb)-configurePkgconfigPackages verbosity pkg_descr progdb enabled-  | null allpkgs = return (pkg_descr, progdb)-  | otherwise    = do-    (_, _, progdb') <- requireProgramVersion-                       (lessVerbose verbosity) pkgConfigProgram-                       (orLaterVersion $ mkVersion [0,9,0]) progdb-    traverse_ requirePkg allpkgs-    mlib' <- traverse addPkgConfigBILib (library pkg_descr)-    libs' <- traverse addPkgConfigBILib (subLibraries pkg_descr)-    exes' <- traverse addPkgConfigBIExe (executables pkg_descr)-    tests' <- traverse addPkgConfigBITest (testSuites pkg_descr)-    benches' <- traverse addPkgConfigBIBench (benchmarks pkg_descr)-    let pkg_descr' = pkg_descr { library = mlib',-                                 subLibraries = libs', executables = exes',-                                 testSuites = tests', benchmarks = benches' }-    return (pkg_descr', progdb')--  where-    allpkgs = concatMap pkgconfigDepends (enabledBuildInfos pkg_descr enabled)-    pkgconfig = getDbProgramOutput (lessVerbose verbosity)-                  pkgConfigProgram progdb--    requirePkg dep@(PkgconfigDependency pkgn range) = do-      version <- pkgconfig ["--modversion", pkg]-                 `catchIO`   (\_ -> die' verbosity notFound)-                 `catchExit` (\_ -> die' verbosity notFound)-      let trim = dropWhile isSpace . dropWhileEnd isSpace-      let v = PkgconfigVersion (toUTF8BS $ trim version)-      if not (withinPkgconfigVersionRange v range)-      then die' verbosity (badVersion v)-      else info verbosity (depSatisfied v)-      where-        notFound     = "The pkg-config package '" ++ pkg ++ "'"-                    ++ versionRequirement-                    ++ " is required but it could not be found."-        badVersion v = "The pkg-config package '" ++ pkg ++ "'"-                    ++ versionRequirement-                    ++ " is required but the version installed on the"-                    ++ " system is version " ++ prettyShow v-        depSatisfied v = "Dependency " ++ prettyShow dep-                      ++ ": using version " ++ prettyShow v--        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)-      return (ccLdOptionsBuildInfo (words ccflags) (words ldflags))---- | 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"]--- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags))----ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo-ccLdOptionsBuildInfo cflags ldflags =-  let (includeDirs',  cflags')   = partition ("-I" `isPrefixOf`) cflags-      (extraLibs',    ldflags')  = partition ("-l" `isPrefixOf`) ldflags-      (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags'-  in mempty {-       includeDirs  = map (drop 2) includeDirs',-       extraLibs    = map (drop 2) extraLibs',-       extraLibDirs = map (drop 2) extraLibDirs',-       ccOptions    = cflags',-       ldOptions    = ldflags''-     }---- -------------------------------------------------------------------------------- Determining the compiler details--configCompilerAuxEx :: ConfigFlags-                    -> IO (Compiler, Platform, ProgramDb)-configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg)-                                           (flagToMaybe $ configHcPath cfg)-                                           (flagToMaybe $ configHcPkg cfg)-                                           programDb-                                           (fromFlag (configVerbosity cfg))-  where-    programDb = mkProgramDb cfg defaultProgramDb--configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath-                 -> ProgramDb -> Verbosity-                 -> IO (Compiler, Platform, ProgramDb)-configCompilerEx Nothing _ _ _ verbosity = die' verbosity "Unknown compiler"-configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do-  (comp, maybePlatform, programDb) <- case hcFlavor of-    GHC   -> GHC.configure  verbosity hcPath hcPkg progdb-    GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb-    UHC   -> UHC.configure  verbosity hcPath hcPkg progdb-    HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg progdb-    _    -> die' verbosity "Unknown compiler"-  return (comp, fromMaybe buildPlatform maybePlatform, programDb)---- -------------------------------------------------------------------------------- Testing C lib and header dependencies---- Try to build a test C program which includes every header and links every--- lib. If that fails, try to narrow it down by preprocessing (only) and linking--- with individual headers and libs.  If none is the obvious culprit then give a--- generic error message.--- TODO: produce a log file from the compiler errors, if any.-checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO ()-checkForeignDeps pkg lbi verbosity =-  ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling-                                                               -- lucky-           (return ())-           (do missingLibs <- findMissingLibs-               missingHdr  <- findOffendingHdr-               explainErrors missingHdr missingLibs)-      where-        allHeaders = collectField includes-        allLibs    = collectField extraLibs--        ifBuildsWith headers args success failure = do-            checkDuplicateHeaders-            ok <- builds (makeProgram headers) args-            if ok then success else failure--        -- Ensure that there is only one header with a given name-        -- in either the generated (most likely by `configure`)-        -- build directory (e.g. `dist/build`) or in the source directory.-        ---        -- If it exists in both, we'll remove the one in the source-        -- directory, as the generated should take precedence.-        ---        -- C compilers like to prefer source local relative includes,-        -- so the search paths provided to the compiler via -I are-        -- ignored if the included file can be found relative to the-        -- including file.  As such we need to take drastic measures-        -- and delete the offending file in the source directory.-        checkDuplicateHeaders = do-          let relIncDirs = filter (not . isAbsolute) (collectField includeDirs)-              isHeader   = isSuffixOf ".h"-          genHeaders <- for relIncDirs $ \dir ->-            fmap (dir </>) . filter isHeader <$>-            listDirectory (buildDir lbi </> dir) `catchIO` (\_ -> return [])-          srcHeaders <- for relIncDirs $ \dir ->-            fmap (dir </>) . filter isHeader <$>-            listDirectory (baseDir lbi </> dir) `catchIO` (\_ -> return [])-          let commonHeaders = concat genHeaders `intersect` concat srcHeaders-          for_ commonHeaders $ \hdr -> do-            warn verbosity $ "Duplicate header found in "-                          ++ (buildDir lbi </> hdr)-                          ++ " and "-                          ++ (baseDir lbi </> hdr)-                          ++ "; removing "-                          ++ (baseDir lbi </> hdr)-            removeFile (baseDir lbi </> hdr)--        findOffendingHdr =-            ifBuildsWith allHeaders ccArgs-                         (return Nothing)-                         (go . Unsafe.tail . inits $ allHeaders) -- inits always contains at least []-            where-              go [] = return Nothing       -- cannot happen-              go (hdrs:hdrsInits) =-                    -- Try just preprocessing first-                    ifBuildsWith hdrs cppArgs-                      -- If that works, try compiling too-                      (ifBuildsWith hdrs ccArgs-                        (go hdrsInits)-                        (return . fmap Right . safeLast $ hdrs))-                      (return . fmap Left . safeLast $ hdrs)---              cppArgs = "-E":commonCppArgs -- preprocess only-              ccArgs  = "-c":commonCcArgs  -- don't try to link--        findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs)-                                       (return [])-                                       (filterM (fmap not . libExists) allLibs)--        libExists lib = builds (makeProgram []) (makeLdArgs [lib])--        baseDir lbi' = fromMaybe "." (takeDirectory <$> cabalFilePath lbi')--        commonCppArgs = platformDefines lbi-                     -- TODO: This is a massive hack, to work around the-                     -- fact that the test performed here should be-                     -- PER-component (c.f. the "I'm Feeling Lucky"; we-                     -- should NOT be glomming everything together.)-                     ++ [ "-I" ++ buildDir lbi </> "autogen" ]-                     -- `configure' may generate headers in the build directory-                     ++ [ "-I" ++ buildDir lbi </> dir-                        | dir <- ordNub (collectField includeDirs)-                        , not (isAbsolute dir)]-                     -- we might also reference headers from the-                     -- packages directory.-                     ++ [ "-I" ++ baseDir lbi </> dir-                        | dir <- ordNub (collectField includeDirs)-                        , not (isAbsolute dir)]-                     ++ [ "-I" ++ dir | dir <- ordNub (collectField includeDirs)-                                      , isAbsolute dir]-                     ++ ["-I" ++ baseDir lbi]-                     ++ collectField cppOptions-                     ++ collectField ccOptions-                     ++ [ "-I" ++ dir-                        | dir <- ordNub [ dir-                                        | dep <- deps-                                        , dir <- IPI.includeDirs dep ]-                                 -- dedupe include dirs of dependencies-                                 -- to prevent quadratic blow-up-                        ]-                     ++ [ opt-                        | dep <- deps-                        , opt <- IPI.ccOptions dep ]--        commonCcArgs  = commonCppArgs-                     ++ collectField ccOptions-                     ++ [ opt-                        | dep <- deps-                        , opt <- IPI.ccOptions dep ]--        commonLdArgs  = [ "-L" ++ dir-                        | dir <- ordNub (collectField extraLibDirs) ]-                     ++ collectField ldOptions-                     ++ [ "-L" ++ dir-                        | dir <- ordNub [ dir-                                        | dep <- deps-                                        , dir <- IPI.libraryDirs dep ]-                        ]-                     --TODO: do we also need dependent packages' ld options?-        makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs--        makeProgram hdrs = unlines $-                           [ "#include \""  ++ hdr ++ "\"" | hdr <- hdrs ] ++-                           ["int main(int argc, char** argv) { return 0; }"]--        collectField f = concatMap f allBi-        allBi = enabledBuildInfos pkg (componentEnabledSpec lbi)-        deps = PackageIndex.topologicalOrder (installedPkgs lbi)--        builds program args = do-            tempDir <- getTemporaryDirectory-            withTempFile tempDir ".c" $ \cName cHnd ->-              withTempFile tempDir "" $ \oNname oHnd -> do-                hPutStrLn cHnd program-                hClose cHnd-                hClose oHnd-                _ <- getDbProgramOutput verbosity-                  gccProgram (withPrograms lbi) (cName:"-o":oNname:args)-                return True-           `catchIO`   (\_ -> return False)-           `catchExit` (\_ -> return False)--        explainErrors Nothing [] = return () -- should be impossible!-        explainErrors _ _-           | isNothing . lookupProgram gccProgram . withPrograms $ lbi--                              = die' verbosity $ unlines-              [ "No working gcc",-                  "This package depends on foreign library but we cannot "-               ++ "find a working C compiler. If you have it in a "-               ++ "non-standard location you can use the --with-gcc "-               ++ "flag to specify it." ]--        explainErrors hdr libs = die' verbosity $ unlines $-             [ if plural-                 then "Missing dependencies on foreign libraries:"-                 else "Missing dependency on a foreign library:"-             | missing ]-          ++ case hdr of-               Just (Left h) -> ["* Missing (or bad) header file: " ++ h ]-               _             -> []-          ++ case libs of-               []    -> []-               [lib] -> ["* Missing (or bad) C library: " ++ lib]-               _     -> ["* Missing (or bad) C libraries: " ++-                         intercalate ", " libs]-          ++ [if plural then messagePlural else messageSingular | missing]-          ++ case hdr of-               Just (Left  _) -> [ headerCppMessage ]-               Just (Right h) -> [ (if missing then "* " else "")-                                   ++ "Bad header file: " ++ h-                                 , headerCcMessage ]-               _              -> []--          where-            plural  = length libs >= 2-            -- Is there something missing? (as opposed to broken)-            missing = not (null libs)-                   || case hdr of Just (Left _) -> True; _ -> False--        messageSingular =-             "This problem can usually be solved by installing the system "-          ++ "package that provides this library (you may need the "-          ++ "\"-dev\" version). If the library is already installed "-          ++ "but in a non-standard location then you can use the flags "-          ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "-          ++ "where it is."-          ++ "If the library file does exist, it may contain errors that "-          ++ "are caught by the C compiler at the preprocessing stage. "-          ++ "In this case you can re-run configure with the verbosity "-          ++ "flag -v3 to see the error messages."-        messagePlural =-             "This problem can usually be solved by installing the system "-          ++ "packages that provide these libraries (you may need the "-          ++ "\"-dev\" versions). If the libraries are already installed "-          ++ "but in a non-standard location then you can use the flags "-          ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "-          ++ "where they are."-          ++ "If the library files do exist, it may contain errors that "-          ++ "are caught by the C compiler at the preprocessing stage. "-          ++ "In this case you can re-run configure with the verbosity "-          ++ "flag -v3 to see the error messages."-        headerCppMessage =-             "If the header file does exist, it may contain errors that "-          ++ "are caught by the C compiler at the preprocessing stage. "-          ++ "In this case you can re-run configure with the verbosity "-          ++ "flag -v3 to see the error messages."-        headerCcMessage =-             "The header file contains a compile error. "-          ++ "You can re-run configure with the verbosity flag "-          ++ "-v3 to see the error messages from the C compiler."---- | Output package check warnings and errors. Exit if any errors.-checkPackageProblems :: Verbosity-                     -> FilePath-                        -- ^ Path to the @.cabal@ file's directory-                     -> GenericPackageDescription-                     -> PackageDescription-                     -> IO ()-checkPackageProblems verbosity dir gpkg pkg = do-  ioChecks      <- checkPackageFiles verbosity pkg dir-  let pureChecks = checkPackage gpkg (Just pkg)-      errors   = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ]-      warnings = [ w | PackageBuildWarning    w <- pureChecks ++ ioChecks ]-  if null errors-    then traverse_ (warn verbosity) warnings-    else die' verbosity (intercalate "\n\n" errors)---- | 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 ])-        $ die' verbosity $ "Operating system: " ++ prettyShow os ++-                ", does not support relocatable builds"-      where-        (Platform _ os) = hostPlatform lbi--    -- Check if the Compiler support relocatable builds-    checkCompiler-        = unless (compilerFlavor comp `elem` [ GHC ])-        $ die' verbosity $ "Compiler: " ++ show comp ++-                ", does not support relocatable builds"-      where-        comp = compiler lbi--    -- Check if all the install dirs are relative to same prefix-    packagePrefixRelative-        = unless (relativeInstallDirs installDirs)-        $ die' verbosity $ "Installation directories are not prefix_relative:\n" ++-                show installDirs-      where-        -- NB: should be good enough to check this against the default-        -- component ID, but if we wanted to be strictly correct we'd-        -- check for each ComponentId.-        installDirs = absoluteInstallDirs pkg lbi NoCopyDest-        p           = prefix installDirs-        relativeInstallDirs (InstallDirs {..}) =-          all isJust-              (fmap (stripPrefix p)-                    [ bindir, libdir, dynlibdir, libexecdir, includedir, datadir-                    , docdir, mandir, htmldir, haddockdir, sysconfdir] )--    -- Check if the library dirs of the dependencies that are in the package-    -- database to which the package is installed are relative to the-    -- prefix of the package-    depsPrefixRelative = do-        pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi))-        traverse_ (doCheck pkgr) ipkgs-      where-        doCheck pkgr ipkg-          | maybe False (== pkgr) (IPI.pkgRoot ipkg)-          = for_ (IPI.libraryDirs ipkg) $ \libdir -> do-              -- When @prefix@ is not under @pkgroot@,-              -- @shortRelativePath prefix pkgroot@ will return a path with-              -- @..@s and following check will fail without @canonicalizePath@.-              canonicalized <- canonicalizePath libdir-              unless (p `isPrefixOf` canonicalized) $-                die' verbosity $ msg libdir-          | otherwise-          = return ()-        -- NB: should be good enough to check this against the default-        -- component ID, but if we wanted to be strictly correct we'd-        -- check for each ComponentId.-        installDirs   = absoluteInstallDirs pkg lbi NoCopyDest-        p             = prefix installDirs-        ipkgs         = PackageIndex.allPackages (installedPkgs lbi)-        msg l         = "Library directory of a dependency: " ++ show l ++-                        "\nis not relative to the installation prefix:\n" ++-                        show p---- -------------------------------------------------------------------------------- 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 libraires 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 X86_64 OSX    ) = goGhcOsx     (foreignLibType flib)-    goGhcPlatform (Platform _      Linux  ) = goGhcLinux   (foreignLibType flib)-    goGhcPlatform (Platform I386   Windows) = goGhcWindows (foreignLibType flib)-    goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib)-    goGhcPlatform _ = unsupported [-        "Building foreign libraries is currently only supported on OSX, "-      , "Linux and Windows"-      ]--    goGhcOsx :: ForeignLibType -> Maybe String-    goGhcOsx ForeignLibNativeShared-      | not (null (foreignLibModDefFile flib)) = unsupported [-            "Module definition file not supported on OSX"-          ]-      | not (null (foreignLibVersionInfo flib)) = unsupported [-            "Foreign library versioning not currently supported on OSX"-          ]-      | otherwise =-          Nothing-    goGhcOsx _ = unsupported [-        "We can currently only build shared foreign libraries on OSX"-      ]--    goGhcLinux :: ForeignLibType -> Maybe String-    goGhcLinux ForeignLibNativeShared-      | not (null (foreignLibModDefFile flib)) = unsupported [-            "Module definition file not supported on Linux"-          ]-      | not (null (foreignLibVersionInfo flib))-          && not (null (foreignLibVersionLinux flib)) = unsupported [-            "You must not specify both lib-version-info and lib-version-linux"-          ]-      | otherwise =-          Nothing-    goGhcLinux _ = unsupported [-        "We can currently only build shared foreign libraries on Linux"-      ]--    goGhcWindows :: ForeignLibType -> Maybe String-    goGhcWindows ForeignLibNativeShared-      | not standalone = unsupported [-            "We can currently only build standalone libraries on Windows. Use\n"-          , "  if os(Windows)\n"-          , "    options: standalone\n"-          , "in your foreign-library stanza."-          ]-      | not (null (foreignLibVersionInfo flib)) = unsupported [-            "Foreign library versioning not currently supported on Windows.\n"-          , "You can specify module definition files in the mod-def-file field."-          ]-      | otherwise =-         Nothing-    goGhcWindows _ = unsupported [-        "We can currently only build shared foreign libraries on Windows"-      ]+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Configure+-- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This deals with the /configure/ phase. It provides the 'configure' action+-- which is given the package description and configure flags. It then tries+-- to: configure the compiler; resolves any conditionals in the package+-- description; resolve the package dependencies; check if all the extensions+-- used by this package are supported by the compiler; check that all the build+-- tools are available (including version checks if appropriate); checks for+-- any required @pkg-config@ packages (updating the 'BuildInfo' with the+-- results)+--+-- Then based on all this it saves the info in the 'LocalBuildInfo' and writes+-- it out to the @dist\/setup-config@ file. It also displays various details to+-- the user, the amount of information displayed depending on the verbosity+-- level.+module Distribution.Simple.Configure+  ( configure+  , configure_setupHooks+  , writePersistBuildConfig+  , getConfigStateFile+  , getPersistBuildConfig+  , checkPersistBuildConfigOutdated+  , tryGetPersistBuildConfig+  , maybeGetPersistBuildConfig+  , findDistPref+  , findDistPrefOrDefault+  , getInternalLibraries+  , computeComponentId+  , computeCompatPackageKey+  , localBuildInfoFile+  , getInstalledPackages+  , getInstalledPackagesMonitorFiles+  , getInstalledPackagesById+  , getPackageDBContents+  , configCompiler+  , configCompilerEx+  , configCompilerAuxEx+  , configCompilerProgDb+  , 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.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.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+  , 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 -> DependencySatisfaction)+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++            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'.+configureFinalizedPackage+  :: 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)+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+    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 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++-- | 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, 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 =+      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) (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)+    goGhcPlatform (Platform _ FreeBSD) = goGhcLinux (foreignLibType flib)+    goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib)+    goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib)+    goGhcPlatform _ =+      unsupported+        [ "Building foreign libraries is currently only supported on Mac OS, "+        , "Linux and Windows"+        ]++    goGhcOsx :: ForeignLibType -> Maybe String+    goGhcOsx ForeignLibNativeShared+      | not (null (foreignLibModDefFile flib)) =+          unsupported+            [ "Module definition file not supported on OSX"+            ]+      | not (null (foreignLibVersionInfo flib)) =+          unsupported+            [ "Foreign library versioning not currently supported on OSX"+            ]+      | otherwise =+          Nothing+    goGhcOsx _ =+      unsupported+        [ "We can currently only build shared foreign libraries on OSX"+        ]++    goGhcLinux :: ForeignLibType -> Maybe String+    goGhcLinux ForeignLibNativeShared+      | not (null (foreignLibModDefFile flib)) =+          unsupported+            [ "Module definition file not supported on Linux"+            ]+      | not (null (foreignLibVersionInfo flib))+          && not (null (foreignLibVersionLinux flib)) =+          unsupported+            [ "You must not specify both lib-version-info and lib-version-linux"+            ]+      | otherwise =+          Nothing+    goGhcLinux _ =+      unsupported+        [ "We can currently only build shared foreign libraries on Linux"+        ]++    goGhcWindows :: ForeignLibType -> Maybe String+    goGhcWindows ForeignLibNativeShared+      | not standalone =+          unsupported+            [ "We can currently only build standalone libraries on Windows. Use\n"+            , "  if os(Windows)\n"+            , "    options: standalone\n"+            , "in your foreign-library stanza."+            ]+      | not (null (foreignLibVersionInfo flib)) =+          unsupported+            [ "Foreign library versioning not currently supported on Windows.\n"+            , "You can specify module definition files in the mod-def-file field."+            ]+      | otherwise =+          Nothing+    goGhcWindows _ =+      unsupported+        [ "We can currently only build shared foreign libraries on Windows"+        ]      standalone :: Bool     standalone = ForeignLibStandalone `elem` foreignLibOptions flib
+ src/Distribution/Simple/ConfigureScript.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+{-# OPTIONS_GHC -Wno-deprecations #-}++-- |+-- Module      :  Distribution.Simple.ConfigureScript+-- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+module Distribution.Simple.ConfigureScript+  ( runConfigureScript+  ) where++import Distribution.Compat.Prelude+import Prelude ()++-- local+import Distribution.PackageDescription+import Distribution.Pretty+import Distribution.Simple.Configure (findDistPrefOrDefault)+import Distribution.Simple.Errors+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Program+import Distribution.Simple.Program.Db+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Config+import Distribution.Simple.Utils+import Distribution.System (Platform, buildPlatform)+import Distribution.Utils.NubList+import Distribution.Utils.Path++-- Base+import System.Directory (createDirectoryIfMissing, doesFileExist)+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)++import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map as Map++runConfigureScript+  :: ConfigFlags+  -> FlagAssignment+  -> ProgramDb+  -> Platform+  -- ^ host platform+  -> IO ()+runConfigureScript cfg flags programDb hp = do+  let commonCfg = configCommonFlags cfg+      verbosity = fromFlag $ setupVerbosity commonCfg+  dist_dir <- findDistPrefOrDefault $ setupDistPref commonCfg+  let build_dir = dist_dir </> makeRelativePathEx "build"+      mbWorkDir = flagToMaybe $ setupWorkingDir commonCfg+      configureScriptPath = packageRoot commonCfg </> "configure"+  confExists <- doesFileExist configureScriptPath+  unless confExists $+    dieWithException verbosity (ConfigureScriptNotFound configureScriptPath)+  configureFile <-+    makeAbsolute $ configureScriptPath+  env <- getEnvironment+  (ccProg, ccFlags) <- configureCCompiler verbosity programDb+  ccProgShort <- getShortPathName ccProg+  -- The C compiler's compilation and linker flags (e.g.+  -- "C compiler flags" and "Gcc Linker flags" from GHC) have already+  -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS+  -- to ccFlags+  -- We don't try and tell configure which ld to use, as we don't have+  -- a way to pass its flags too++  -- Do not presume the CXX compiler is available, but it always will be after 9.4.+  (mcxxProgShort, mcxxFlags) <- do+    mprog <- needProgram verbosity gppProgram programDb+    case mprog of+      Just (p, _) -> do+        let pInv = programInvocation p []+        let cxxProg = progInvokePath pInv+        let cxxFlags = progInvokeArgs pInv+        cxxProgShort <- getShortPathName cxxProg+        return (Just cxxProgShort, Just cxxFlags)+      Nothing -> return (Nothing, Nothing)++  let configureFile' = toUnix configureFile+  -- autoconf is fussy about filenames, and has a set of forbidden+  -- characters that can't appear in the build directory, etc:+  -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions+  --+  -- This has caused hard-to-debug failures in the past (#5368), so we+  -- detect some cases early and warn with a clear message. Windows's+  -- use of backslashes is problematic here, so we'll switch to+  -- slashes, but we do still want to fail on backslashes in POSIX+  -- paths.+  --+  -- TODO: We don't check for colons, tildes or leading dashes. We+  -- also should check the builddir's path, destdir, and all other+  -- paths as well.+  for_ badAutoconfCharacters $ \(c, cname) ->+    when (c `elem` FilePath.dropDrive configureFile') $+      warn verbosity $+        concat+          [ "The path to the './configure' script, '"+          , configureFile'+          , "', contains the character '"+          , [c]+          , "' ("+          , cname+          , ")."+          , " This may cause the script to fail with an obscure error, or for"+          , " building the package to fail later."+          ]++  let+    -- Convert a flag name to name of environment variable to represent its+    -- value for the configure script.+    flagEnvVar :: FlagName -> String+    flagEnvVar flag = "CABAL_FLAG_" ++ map f (unFlagName flag)+      where+        f c+          | isAlphaNum c = c+          | otherwise = '_'+    -- A map from such env vars to every flag name and value where the name+    -- name maps to that that env var.+    cabalFlagMap :: Map String (NonEmpty (FlagName, Bool))+    cabalFlagMap =+      Map.fromListWith+        (<>)+        [ (flagEnvVar flag, (flag, bool) :| [])+        | (flag, bool) <- unFlagAssignment flags+        ]+  -- A map from env vars to flag names to the single flag we will go with+  cabalFlagMapDeconflicted :: Map String (FlagName, Bool) <-+    flip Map.traverseWithKey cabalFlagMap $ \envVar -> \case+      -- No conflict: no problem+      singleFlag :| [] -> pure singleFlag+      -- Conflict: warn and discard all but first+      collidingFlags@(firstFlag :| _ : _) -> do+        let quote s = "'" ++ s ++ "'"+            toName = quote . unFlagName . fst+            renderedList = intercalate ", " $ NonEmpty.toList $ toName <$> collidingFlags+        warn verbosity $+          unwords+            [ "Flags"+            , renderedList+            , "all map to the same environment variable"+            , quote envVar+            , "causing a collision."+            , "The value first flag"+            , toName firstFlag+            , "will be used."+            ]+        pure firstFlag++  let cabalFlagEnv =+        [ (envVar, Just val)+        | (envVar, (_, bool)) <- Map.toList cabalFlagMapDeconflicted+        , let val = if bool then "1" else "0"+        ]+          ++ [+               ( "CABAL_FLAGS"+               , Just $ unwords [showFlagValue fv | fv <- unFlagAssignment flags]+               )+             ]+  let extraPath = fromNubList $ configProgramPathExtra cfg+  let mkFlagsEnv fs var = maybe (unwords fs) (++ (" " ++ unwords fs)) (lookup var env)+      spSep = [FilePath.searchPathSeparator]+      pathEnv =+        maybe+          (intercalate spSep extraPath)+          ((intercalate spSep extraPath ++ spSep) ++)+          $ lookup "PATH" env+      overEnv =+        ("CFLAGS", Just (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]+          ++ ["CXX=" ++ cxxProgShort | Just cxxProgShort <- [mcxxProgShort]]+          ++ maybeHostFlag+      shProg = simpleProgram "sh"+  progDb <- prependProgramSearchPath verbosity extraPath [] emptyProgramDb+  shConfiguredProg <-+    lookupProgram shProg+      `fmap` configureProgram verbosity shProg progDb+  case shConfiguredProg of+    Just sh -> do+      let build_in = interpretSymbolicPath mbWorkDir build_dir+      createDirectoryIfMissing True build_in+      runProgramInvocation verbosity $+        (programInvocation (sh{programOverrideEnv = overEnv}) args')+          { progInvokeCwd = Just build_in+          }+    Nothing -> dieWithException verbosity NotFoundMsg+  where+    args = configureArgs backwardsCompatHack cfg+    backwardsCompatHack = False++-- | Convert Windows path to Unix ones+toUnix :: String -> String+#ifdef mingw32_HOST_OS+toUnix s = let tmp = normalise s+               (l, rest) = case splitDrive tmp of+                             ([],  x) -> ("/"      , x)+                             (h:_, x) -> ('/':h:"/", x)+               parts = FilePath.splitDirectories rest+           in  l ++ intercalate "/" parts+#else+toUnix s = intercalate "/" $ FilePath.splitDirectories s+#endif++badAutoconfCharacters :: [(Char, String)]+badAutoconfCharacters =+  [ (' ', "space")+  , ('\t', "tab")+  , ('\n', "newline")+  , ('\0', "null")+  , ('"', "double quote")+  , ('#', "hash")+  , ('$', "dollar sign")+  , ('&', "ampersand")+  , ('\'', "single quote")+  , ('(', "left bracket")+  , (')', "right bracket")+  , ('*', "star")+  , (';', "semicolon")+  , ('<', "less-than sign")+  , ('=', "equals sign")+  , ('>', "greater-than sign")+  , ('?', "question mark")+  , ('[', "left square bracket")+  , ('\\', "backslash")+  , ('`', "backtick")+  , ('|', "pipe")+  ]
+ src/Distribution/Simple/Errors.hs view
@@ -0,0 +1,806 @@+-----------------------------------------------------------------------------++-- Module      :  Distribution.Simple.Errors+-- Copyright   :  Suganya Arun+-- License     :  BSD3+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- A collection of Exception Types in the Cabal library package++module Distribution.Simple.Errors+  ( CabalException (..)+  , FailedDependency (..)+  , exceptionCode+  , exceptionMessage+  ) where++import Distribution.Compat.Prelude+import Distribution.Compiler+import Distribution.InstalledPackageInfo+import Distribution.ModuleName+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Pretty+  ( Pretty (pretty)+  , prettyShow+  )+import Distribution.Simple.InstallDirs+import Distribution.Simple.PreProcess.Types (Suffix)+import Distribution.Simple.SetupHooks.Errors+import Distribution.System (OS)+import Distribution.Types.MissingDependency (MissingDependency)+import Distribution.Types.VersionRange.Internal ()+import Distribution.Version+import Text.PrettyPrint++data FailedDependency+  = DependencyNotExists PackageName+  | DependencyMissingInternal PackageName LibraryName+  | DependencyNoVersion Dependency+  deriving (Show)++-- Types representing exceptions thrown by functions in all the modules of Cabal Package+data CabalException+  = NoBenchMarkProgram FilePath+  | EnableBenchMark+  | BenchMarkNameDisabled String+  | NoBenchMark String+  | -- | @NoLibraryFound@ has been downgraded to a warning, and is therefore no longer emitted.+    NoLibraryFound+  | CompilerNotInstalled CompilerFlavor+  | CantFindIncludeFile String+  | UnsupportedTestSuite String+  | UnsupportedBenchMark String+  | NoIncludeFileFound String+  | NoModuleFound ModuleName [Suffix]+  | RegMultipleInstancePkg+  | SuppressingChecksOnFile+  | NoSupportDirStylePackageDb+  | OnlySupportSpecificPackageDb+  | FailedToParseOutputDescribe String PackageId+  | DumpFailed String String+  | FailedToParseOutputDump String+  | ListFailed String+  | FailedToParseOutputList String+  | ProgramNotFound String+  | NoSupportForHoogle+  | NoSupportForQuickJumpFlag+  | NoGHCVersionFromHaddock+  | NoGHCVersionFromCompiler+  | HaddockAndGHCVersionDoesntMatch Version Version+  | MustHaveSharedLibraries+  | HaddockPackageFlags [(InstalledPackageInfo, [UnitId])]+  | UnknownCompilerFlavor CompilerFlavor+  | FailedToDetermineTarget+  | NoMultipleTargets+  | REPLNotSupported+  | NoSupportBuildingTestSuite TestType+  | NoSupportBuildingBenchMark BenchmarkType+  | BuildingNotSupportedWithCompiler+  | PkgDumpFailed+  | FailedToParseOutput+  | CantFindSourceModule ModuleName+  | VersionMismatchJS FilePath Version FilePath Version+  | VersionMismatchGHCJS FilePath Version FilePath Version+  | GlobalPackageDBLimitation+  | GlobalPackageDBSpecifiedFirst+  | MatchDirFileGlob String+  | MatchDirFileGlobErrors [String]+  | ErrorParsingFileDoesntExist FilePath+  | FailedParsing String+  | NotFoundMsg+  | UnrecognisedBuildTarget [String]+  | ReportBuildTargetProblems [(String, [String], String)]+  | UnknownBuildTarget [(String, [(String, String)])]+  | AmbiguousBuildTarget [(String, [(String, String)])]+  | CheckBuildTargets String+  | VersionMismatchGHC FilePath Version FilePath Version+  | CheckPackageDbStackPost76+  | CheckPackageDbStackPre76+  | GlobalPackageDbSpecifiedFirst+  | CantInstallForeignLib+  | NoSupportForPreProcessingTest TestType+  | NoSupportForPreProcessingBenchmark BenchmarkType+  | CantFindSourceForPreProcessFile String+  | NoSupportPreProcessingTestExtras TestType+  | NoSupportPreProcessingBenchmarkExtras BenchmarkType+  | UnlitException String+  | RunProgramInvocationException FilePath String+  | GetProgramInvocationException FilePath String+  | GetProgramInvocationLBSException FilePath String+  | CheckSemaphoreSupport+  | NoLibraryForPackage+  | SanityCheckHookedBuildInfo UnqualComponentName+  | ConfigureScriptNotFound FilePath+  | NoValidComponent+  | ConfigureEitherSingleOrAll+  | ConfigCIDValidForPreComponent+  | SanityCheckForEnableComponents+  | SanityCheckForDynamicStaticLinking+  | UnsupportedLanguages PackageIdentifier CompilerId [String]+  | UnsupportedLanguageExtension PackageIdentifier CompilerId [String]+  | CantFindForeignLibraries [String]+  | ExpectedAbsoluteDirectory FilePath+  | FlagsNotSpecified [FlagName]+  | EncounteredMissingDependency [MissingDependency]+  | CompilerDoesn'tSupportThinning+  | CompilerDoesn'tSupportReexports+  | CompilerDoesn'tSupportBackpack+  | LibraryWithinSamePackage [PackageId]+  | ReportFailedDependencies [FailedDependency] String+  | NoPackageDatabaseSpecified+  | HowToFindInstalledPackages CompilerFlavor+  | PkgConfigNotFound String String+  | BadVersion String String PkgconfigVersion+  | UnknownCompilerException+  | NoWorkingGcc+  | NoOSSupport OS String+  | NoCompilerSupport String+  | InstallDirsNotPrefixRelative (InstallDirs FilePath)+  | ExplainErrors (Maybe (Either [Char] [Char])) [String]+  | CheckPackageProblems [String]+  | LibDirDepsPrefixNotRelative FilePath FilePath+  | CombinedConstraints Doc+  | CantParseGHCOutput+  | IncompatibleWithCabal String String+  | Couldn'tFindTestProgram FilePath+  | TestCoverageSupport+  | Couldn'tFindTestProgLibV09 FilePath+  | TestCoverageSupportLibV09+  | RawSystemStdout String+  | FindFile FilePath+  | FindModuleFileEx ModuleName [Suffix] [FilePath]+  | MultipleFilesWithExtension String+  | NoDesc+  | MultiDesc [String]+  | RelocRegistrationInfo+  | CreatePackageDB+  | WithHcPkg String+  | RegisMultiplePkgNotSupported+  | RegisteringNotImplemented+  | NoTestSuitesEnabled+  | TestNameDisabled String+  | NoSuchTest String+  | ConfigureProgram String FilePath+  | RequireProgram String+  | NoProgramFound String VersionRange+  | BadVersionDb String Version VersionRange FilePath+  | UnknownVersionDb String VersionRange FilePath+  | MissingCoveredInstalledLibrary UnitId+  | SetupHooksException SetupHooksException+  | MultiReplDoesNotSupportComplexReexportedModules PackageName ComponentName+  deriving (Show)++exceptionCode :: CabalException -> Int+exceptionCode e = case e of+  NoBenchMarkProgram{} -> 1678+  EnableBenchMark{} -> 1453+  BenchMarkNameDisabled{} -> 2781+  NoBenchMark{} -> 1654+  NoLibraryFound -> 2546+  CompilerNotInstalled{} -> 7465+  CantFindIncludeFile{} -> 3876+  UnsupportedTestSuite{} -> 3245+  UnsupportedBenchMark{} -> 9123+  NoIncludeFileFound{} -> 2987+  NoModuleFound{} -> 6421+  RegMultipleInstancePkg{} -> 3421+  SuppressingChecksOnFile{} -> 5436+  NoSupportDirStylePackageDb -> 2980+  OnlySupportSpecificPackageDb -> 6547+  FailedToParseOutputDescribe{} -> 7218+  DumpFailed{} -> 6736+  FailedToParseOutputDump{} -> 9076+  ListFailed{} -> 5109+  FailedToParseOutputList{} -> 7650+  ProgramNotFound{} -> 4123+  NoSupportForHoogle{} -> 8706+  NoSupportForQuickJumpFlag{} -> 7086+  NoGHCVersionFromHaddock -> 5045+  NoGHCVersionFromCompiler -> 4098+  HaddockAndGHCVersionDoesntMatch{} -> 1998+  MustHaveSharedLibraries{} -> 6032+  HaddockPackageFlags{} -> 4569+  UnknownCompilerFlavor{} -> 3102+  FailedToDetermineTarget{} -> 5049+  NoMultipleTargets{} -> 6091+  REPLNotSupported{} -> 1098+  NoSupportBuildingTestSuite{} -> 4106+  NoSupportBuildingBenchMark{} -> 5320+  BuildingNotSupportedWithCompiler{} -> 7077+  -- Retired: ProvideHaskellSuiteTool{} -> 7509+  -- Retired: CannotDetermineCompilerVersion{} -> 4519+  PkgDumpFailed{} -> 2291+  FailedToParseOutput{} -> 5500+  CantFindSourceModule{} -> 8870+  VersionMismatchJS{} -> 9001+  VersionMismatchGHCJS{} -> 4001+  GlobalPackageDBLimitation{} -> 5002+  GlobalPackageDBSpecifiedFirst{} -> 3901+  MatchDirFileGlob{} -> 9760+  MatchDirFileGlobErrors{} -> 6661+  ErrorParsingFileDoesntExist{} -> 1234+  FailedParsing{} -> 6565+  NotFoundMsg{} -> 8011+  UnrecognisedBuildTarget{} -> 3410+  ReportBuildTargetProblems{} -> 5504+  UnknownBuildTarget{} -> 4444+  AmbiguousBuildTarget{} -> 7865+  CheckBuildTargets{} -> 4733+  VersionMismatchGHC{} -> 4000+  CheckPackageDbStackPost76{} -> 3000+  CheckPackageDbStackPre76{} -> 5640+  GlobalPackageDbSpecifiedFirst{} -> 2345+  CantInstallForeignLib{} -> 8221+  NoSupportForPreProcessingTest{} -> 3008+  NoSupportForPreProcessingBenchmark{} -> 6990+  CantFindSourceForPreProcessFile{} -> 7554+  NoSupportPreProcessingTestExtras{} -> 7886+  NoSupportPreProcessingBenchmarkExtras{} -> 9999+  UnlitException{} -> 5454+  RunProgramInvocationException{} -> 8012+  GetProgramInvocationException{} -> 7300+  GetProgramInvocationLBSException{} -> 6578+  CheckSemaphoreSupport{} -> 2002+  NoLibraryForPackage{} -> 8004+  SanityCheckHookedBuildInfo{} -> 6007+  ConfigureScriptNotFound{} -> 4567+  NoValidComponent{} -> 5680+  ConfigureEitherSingleOrAll{} -> 2001+  ConfigCIDValidForPreComponent{} -> 7006+  SanityCheckForEnableComponents{} -> 5004+  SanityCheckForDynamicStaticLinking{} -> 4007+  UnsupportedLanguages{} -> 8074+  UnsupportedLanguageExtension{} -> 5656+  CantFindForeignLibraries{} -> 4574+  ExpectedAbsoluteDirectory{} -> 6662+  FlagsNotSpecified{} -> 9080+  EncounteredMissingDependency{} -> 8010+  CompilerDoesn'tSupportThinning{} -> 4003+  CompilerDoesn'tSupportReexports{} -> 3456+  CompilerDoesn'tSupportBackpack{} -> 5446+  LibraryWithinSamePackage{} -> 7007+  ReportFailedDependencies{} -> 4321+  NoPackageDatabaseSpecified{} -> 2300+  HowToFindInstalledPackages{} -> 3003+  PkgConfigNotFound{} -> 7123+  BadVersion{} -> 7600+  UnknownCompilerException{} -> 3022+  NoWorkingGcc{} -> 1088+  NoOSSupport{} -> 3339+  NoCompilerSupport{} -> 2290+  InstallDirsNotPrefixRelative{} -> 6000+  ExplainErrors{} -> 4345+  CheckPackageProblems{} -> 5559+  LibDirDepsPrefixNotRelative{} -> 6667+  CombinedConstraints{} -> 5000+  CantParseGHCOutput{} -> 1980+  IncompatibleWithCabal{} -> 8123+  Couldn'tFindTestProgram{} -> 5678+  TestCoverageSupport{} -> 7890+  Couldn'tFindTestProgLibV09{} -> 9012+  TestCoverageSupportLibV09{} -> 1076+  RawSystemStdout{} -> 3098+  FindFile{} -> 2115+  FindModuleFileEx{} -> 6663+  MultipleFilesWithExtension{} -> 3333+  NoDesc{} -> 7654+  MultiDesc{} -> 5554+  RelocRegistrationInfo{} -> 4343+  CreatePackageDB{} -> 6787+  WithHcPkg{} -> 9876+  RegisMultiplePkgNotSupported{} -> 7632+  RegisteringNotImplemented{} -> 5411+  NoTestSuitesEnabled{} -> 9061+  TestNameDisabled{} -> 8210+  NoSuchTest{} -> 8000+  ConfigureProgram{} -> 5490+  RequireProgram{} -> 6666+  NoProgramFound{} -> 7620+  BadVersionDb{} -> 8038+  UnknownVersionDb{} -> 1008+  MissingCoveredInstalledLibrary{} -> 9341+  SetupHooksException err ->+    setupHooksExceptionCode err+  MultiReplDoesNotSupportComplexReexportedModules{} -> 9355++versionRequirement :: VersionRange -> String+versionRequirement range+  | isAnyVersion range = ""+  | otherwise = " version " ++ prettyShow range++exceptionMessage :: CabalException -> String+exceptionMessage e = case e of+  NoBenchMarkProgram cmd -> "Could not find benchmark program \"" ++ cmd ++ "\". Did you build the package first?"+  EnableBenchMark -> "No benchmarks enabled. Did you remember to \'Setup configure\' with " ++ "\'--enable-benchmarks\'?"+  BenchMarkNameDisabled bmName -> "Package configured with benchmark " ++ bmName ++ " disabled."+  NoBenchMark bmName -> "no such benchmark: " ++ bmName+  NoLibraryFound -> "No executables and no library found. Nothing to do."+  CompilerNotInstalled compilerFlavor -> "installing with " ++ prettyShow compilerFlavor ++ "is not implemented"+  CantFindIncludeFile file -> "can't find include file " ++ file+  UnsupportedTestSuite test_type -> "Unsupported test suite type: " ++ test_type+  UnsupportedBenchMark benchMarkType -> "Unsupported benchmark type: " ++ benchMarkType+  NoIncludeFileFound f -> "can't find include file " ++ f+  NoModuleFound m suffixes ->+    "Could not find module: "+      ++ prettyShow m+      ++ " with any suffix: "+      ++ show (map prettyShow suffixes)+      ++ ".\n"+      ++ "If the module "+      ++ "is autogenerated it should be added to 'autogen-modules'."+  RegMultipleInstancePkg -> "HcPkg.register: the compiler does not support registering multiple instances of packages."+  SuppressingChecksOnFile -> "HcPkg.register: the compiler does not support suppressing checks on files."+  NoSupportDirStylePackageDb -> "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs"+  OnlySupportSpecificPackageDb -> "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now"+  FailedToParseOutputDescribe programId pkgId -> "failed to parse output of '" ++ programId ++ " describe " ++ prettyShow pkgId ++ "'"+  DumpFailed programId exception -> programId ++ " dump failed: " ++ exception+  FailedToParseOutputDump programId -> "failed to parse output of '" ++ programId ++ " dump'"+  ListFailed programId -> programId ++ " list failed"+  FailedToParseOutputList programId -> "failed to parse output of '" ++ programId ++ " list'"+  ProgramNotFound progName -> "The program '" ++ progName ++ "' is required but it could not be found"+  NoSupportForHoogle -> "Haddock 2.0 and 2.1 do not support the --hoogle flag."+  NoSupportForQuickJumpFlag -> "Haddock prior to 2.19 does not support the --quickjump flag."+  NoGHCVersionFromHaddock -> "Could not get GHC version from Haddock"+  NoGHCVersionFromCompiler -> "Could not get GHC version from compiler"+  HaddockAndGHCVersionDoesntMatch ghcVersion haddockGhcVersion ->+    "Haddock's internal GHC version must match the configured "+      ++ "GHC version.\n"+      ++ "The GHC version is "+      ++ prettyShow ghcVersion+      ++ " but "+      ++ "haddock is using GHC version "+      ++ prettyShow haddockGhcVersion+  MustHaveSharedLibraries -> "Must have vanilla or shared libraries enabled in order to run haddock"+  HaddockPackageFlags inf ->+    "internal error when calculating transitive "+      ++ "package dependencies.\nDebug info: "+      ++ show inf+  UnknownCompilerFlavor compilerFlavor -> "dumpBuildInfo: Unknown compiler flavor: " ++ show compilerFlavor+  FailedToDetermineTarget -> "Failed to determine target."+  NoMultipleTargets -> "The 'repl' command does not support multiple targets at once."+  REPLNotSupported -> "A REPL is not supported with this compiler."+  NoSupportBuildingTestSuite 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."+  PkgDumpFailed -> "pkg dump failed"+  FailedToParseOutput -> "failed to parse output of 'pkg dump'"+  CantFindSourceModule moduleName -> "can't find source for module " ++ prettyShow moduleName+  VersionMismatchJS ghcjsProgPath ghcjsVersion ghcjsPkgProgPath ghcjsPkgGhcjsVersion ->+    "Version mismatch between ghcjs and ghcjs-pkg: "+      ++ show ghcjsProgPath+      ++ " is version "+      ++ prettyShow ghcjsVersion+      ++ " "+      ++ show ghcjsPkgProgPath+      ++ " is version "+      ++ prettyShow ghcjsPkgGhcjsVersion+  VersionMismatchGHCJS ghcjsProgPath ghcjsGhcVersion ghcjsPkgProgPath ghcjsPkgVersion ->+    "Version mismatch between ghcjs and ghcjs-pkg: "+      ++ show ghcjsProgPath+      ++ " was built with GHC version "+      ++ prettyShow ghcjsGhcVersion+      ++ " "+      ++ show ghcjsPkgProgPath+      ++ " was built with GHC version "+      ++ prettyShow ghcjsPkgVersion+  GlobalPackageDBLimitation ->+    "With current ghc versions the global package db is always used "+      ++ "and must be listed first. This ghc limitation may be lifted in "+      ++ "the future, see https://gitlab.haskell.org/ghc/ghc/-/issues/5977"+  GlobalPackageDBSpecifiedFirst ->+    "If the global package db is specified, it must be "+      ++ "specified first and cannot be specified multiple times"+  MatchDirFileGlob pathError -> pathError+  MatchDirFileGlobErrors errors -> unlines errors+  ErrorParsingFileDoesntExist filePath -> "Error Parsing: file \"" ++ filePath ++ "\" doesn't exist. Cannot continue."+  FailedParsing name -> "Failed parsing \"" ++ name ++ "\"."+  NotFoundMsg ->+    "The package has a './configure' script. "+      ++ "If you are on Windows, This requires a "+      ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. "+      ++ "If you are not on Windows, ensure that an 'sh' command "+      ++ "is discoverable in your path."+  UnrecognisedBuildTarget target ->+    unlines+      [ "Unrecognised build target '" ++ name ++ "'."+      | name <- target+      ]+      ++ "Examples:\n"+      ++ " - build foo          -- component name "+      ++ "(library, executable, test-suite or benchmark)\n"+      ++ " - build Data.Foo     -- module name\n"+      ++ " - build Data/Foo.hsc -- file name\n"+      ++ " - build lib:foo exe:foo   -- component qualified by kind\n"+      ++ " - build foo:Data.Foo      -- module qualified by component\n"+      ++ " - build foo:Data/Foo.hsc  -- file qualified by component"+  ReportBuildTargetProblems targets ->+    unlines+      [ "Unrecognised build target '"+        ++ target+        ++ "'.\n"+        ++ "Expected a "+        ++ intercalate " or " expected+        ++ ", rather than '"+        ++ got+        ++ "'."+      | (target, expected, got) <- targets+      ]+  UnknownBuildTarget targets ->+    unlines+      [ "Unknown build target '"+        ++ target+        ++ "'.\nThere is no "+        ++ intercalate+          " or "+          [ mungeThing thing ++ " '" ++ got ++ "'"+          | (thing, got) <- nosuch+          ]+        ++ "."+      | (target, nosuch) <- targets+      ]+    where+      mungeThing "file" = "file target"+      mungeThing thing = thing+  AmbiguousBuildTarget targets ->+    unlines+      [ "Ambiguous build target '"+        ++ target+        ++ "'. It could be:\n "+        ++ unlines+          [ "   "+            ++ ut+            ++ " ("+            ++ bt+            ++ ")"+          | (ut, bt) <- amb+          ]+      | (target, amb) <- targets+      ]+  CheckBuildTargets errorStr -> errorStr+  VersionMismatchGHC ghcProgPath ghcVersion ghcPkgProgPath ghcPkgVersion ->+    "Version mismatch between ghc and ghc-pkg: "+      ++ ghcProgPath+      ++ " is version "+      ++ prettyShow ghcVersion+      ++ " "+      ++ ghcPkgProgPath+      ++ " is version "+      ++ prettyShow ghcPkgVersion+  CheckPackageDbStackPost76 ->+    "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"+  CantInstallForeignLib -> "Can't install foreign-library symlink on non-Linux OS"+  NoSupportForPreProcessingTest tt ->+    "No support for preprocessing test "+      ++ "suite type "+      ++ prettyShow tt+  NoSupportForPreProcessingBenchmark tt ->+    "No support for preprocessing benchmark type "+      ++ prettyShow tt+  CantFindSourceForPreProcessFile errorStr -> errorStr+  NoSupportPreProcessingTestExtras tt ->+    "No support for preprocessing test suite type "+      ++ prettyShow tt+  NoSupportPreProcessingBenchmarkExtras tt ->+    "No support for preprocessing benchmark "+      ++ "type "+      ++ prettyShow tt+  UnlitException str -> str+  RunProgramInvocationException path errors -> "'" ++ path ++ "' exited with an error:\n" ++ errors+  GetProgramInvocationException path errors -> "'" ++ path ++ "' exited with an error:\n" ++ errors+  GetProgramInvocationLBSException path errors -> "'" ++ path ++ "' exited with an error:\n" ++ errors+  CheckSemaphoreSupport ->+    "Your compiler does not support the -jsem flag. "+      ++ "To use this feature you must use GHC 9.8 or later."+  NoLibraryForPackage ->+    "The buildinfo contains info for a library, "+      ++ "but the package does not have a library."+  SanityCheckHookedBuildInfo exe1 ->+    "The buildinfo contains info for an executable called '"+      ++ prettyShow exe1+      ++ "' but the package does not have an "+      ++ "executable with that name."+  ConfigureScriptNotFound fp -> "configure script not found at " ++ fp ++ "."+  NoValidComponent -> "No valid component targets found"+  ConfigureEitherSingleOrAll -> "Can only configure either a single component or all of them"+  ConfigCIDValidForPreComponent -> "--cid is only supported for per-component configure"+  SanityCheckForEnableComponents ->+    "--enable-tests/--enable-benchmarks are incompatible with"+      ++ " explicitly specifying a component to configure."+  SanityCheckForDynamicStaticLinking ->+    "--enable-executable-dynamic and --enable-executable-static"+      ++ " are incompatible with each other."+  UnsupportedLanguages pkgId compilerId langs ->+    "The package "+      ++ prettyShow pkgId+      ++ " requires the following languages which are not "+      ++ "supported by "+      ++ prettyShow compilerId+      ++ ": "+      ++ intercalate ", " langs+  UnsupportedLanguageExtension pkgId compilerId exts ->+    "The package "+      ++ prettyShow pkgId+      ++ " requires the following language extensions which are not "+      ++ "supported by "+      ++ prettyShow compilerId+      ++ ": "+      ++ intercalate ", " exts+  CantFindForeignLibraries unsupportedFLibs ->+    "Cannot build some foreign libraries: "+      ++ intercalate ", " unsupportedFLibs+  ExpectedAbsoluteDirectory fPath -> "expected an absolute directory name for --prefix: " ++ fPath+  FlagsNotSpecified diffFlags ->+    "'--exact-configuration' was given, "+      ++ "but the following flags were not specified: "+      ++ intercalate ", " (map show diffFlags)+  EncounteredMissingDependency missing ->+    "Encountered missing or private dependencies:\n"+      ++ ( render+            . nest 4+            . sep+            . punctuate comma+            . map pretty+            $ missing+         )+  CompilerDoesn'tSupportThinning ->+    "Your compiler does not support thinning and renaming on "+      ++ "package flags.  To use this feature you must use "+      ++ "GHC 7.9 or later."+  CompilerDoesn'tSupportReexports ->+    "Your compiler does not support module re-exports. To use "+      ++ "this feature you must use GHC 7.9 or later."+  CompilerDoesn'tSupportBackpack ->+    "Your compiler does not support Backpack. To use "+      ++ "this feature you must use GHC 8.1 or later."+  LibraryWithinSamePackage internalPkgDeps ->+    "The field 'build-depends: "+      ++ intercalate ", " (map (prettyShow . packageName) internalPkgDeps)+      ++ "' refers to a library which is defined within the same "+      ++ "package. To use this feature the package must specify at "+      ++ "least 'cabal-version: >= 1.8'."+  ReportFailedDependencies failed hackageUrl -> intercalate "\n\n" (map reportFailedDependency failed)+    where+      reportFailedDependency (DependencyNotExists pkgname) =+        "there is no version of "+          ++ prettyShow pkgname+          ++ " installed.\n"+          ++ "Perhaps you need to download and install it from\n"+          ++ hackageUrl+          ++ prettyShow pkgname+          ++ "?"+      reportFailedDependency (DependencyMissingInternal pkgname lib) =+        "internal dependency "+          ++ prettyShow (prettyLibraryNameComponent lib)+          ++ " not installed.\n"+          ++ "Perhaps you need to configure and install it first?\n"+          ++ "(This library was defined by "+          ++ prettyShow pkgname+          ++ ")"+      reportFailedDependency (DependencyNoVersion dep) =+        "cannot satisfy dependency " ++ prettyShow (simplifyDependency dep) ++ "\n"+  NoPackageDatabaseSpecified ->+    "No package databases have been specified. If you use "+      ++ "--package-db=clear, you must follow it with --package-db= "+      ++ "with 'global', 'user' or a specific file."+  HowToFindInstalledPackages flv ->+    "don't know how to find the installed packages for "+      ++ prettyShow flv+  PkgConfigNotFound pkg versionReq ->+    "The pkg-config package '"+      ++ pkg+      ++ "'"+      ++ versionReq+      ++ " is required but it could not be found."+  BadVersion pkg versionReq v ->+    "The pkg-config package '"+      ++ pkg+      ++ "'"+      ++ versionReq+      ++ " is required but the version installed on the"+      ++ " system is version "+      ++ prettyShow v+  UnknownCompilerException -> "Unknown compiler"+  NoWorkingGcc ->+    unlines+      [ "No working gcc"+      , "This package depends on a foreign library but we cannot "+          ++ "find a working C compiler. If you have it in a "+          ++ "non-standard location you can use the --with-gcc "+          ++ "flag to specify it."+      ]+  NoOSSupport os what ->+    "Operating system: "+      ++ prettyShow os+      ++ ", does not support "+      ++ what+  NoCompilerSupport comp ->+    "Compiler: "+      ++ comp+      ++ ", does not support relocatable builds"+  InstallDirsNotPrefixRelative installDirs -> "Installation directories are not prefix_relative:\n" ++ show installDirs+  ExplainErrors hdr libs ->+    unlines $+      [ if plural+        then "Missing dependencies on foreign libraries:"+        else "Missing dependency on a foreign library:"+      | missing+      ]+        ++ case hdr of+          Just (Left h) -> ["* Missing (or bad) header file: " ++ h]+          _ -> []+        ++ case libs of+          [] -> []+          [lib] -> ["* Missing (or bad) C library: " ++ lib]+          _ ->+            [ "* Missing (or bad) C libraries: "+                ++ intercalate ", " libs+            ]+              ++ [if plural then messagePlural else messageSingular | missing]+        ++ case hdr of+          Just (Left _) -> [headerCppMessage]+          Just (Right h) ->+            [ (if missing then "* " else "")+                ++ "Bad header file: "+                ++ h+            , headerCcMessage+            ]+          _ -> []+    where+      plural = length libs >= 2+      -- Is there something missing? (as opposed to broken)+      missing =+        not (null libs)+          || case hdr of Just (Left _) -> True; _ -> False+      messageSingular =+        "This problem can usually be solved by installing the system "+          ++ "package that provides this library (you may need the "+          ++ "\"-dev\" version). If the library is already installed "+          ++ "but in a non-standard location then you can use the flags "+          ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "+          ++ "where it is."+          ++ "If the library file does exist, it may contain errors that "+          ++ "are caught by the C compiler at the preprocessing stage. "+          ++ "In this case you can re-run 'Setup configure' with the "+          ++ "verbosity flag -v3 to see the error messages."+      messagePlural =+        "This problem can usually be solved by installing the system "+          ++ "packages that provide these libraries (you may need the "+          ++ "\"-dev\" versions). If the libraries are already installed "+          ++ "but in a non-standard location then you can use the flags "+          ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "+          ++ "where they are."+          ++ "If the library files do exist, it may contain errors that "+          ++ "are caught by the C compiler at the preprocessing stage. "+          ++ "In this case you can re-run 'Setup configure' with the "+          ++ "verbosity flag -v3 to see the error messages."+      headerCppMessage =+        "If the header file does exist, it may contain errors that "+          ++ "are caught by the C compiler at the preprocessing stage. "+          ++ "In this case you can re-run 'Setup configure' with the "+          ++ "verbosity flag -v3 to see the error messages."+      headerCcMessage =+        "The header file contains a compile error. "+          ++ "You can re-run 'Setup configure' with the verbosity flag "+          ++ "-v3 to see the error messages from the C compiler."+  CheckPackageProblems errors -> intercalate "\n\n" errors+  LibDirDepsPrefixNotRelative l p ->+    "Library directory of a dependency: "+      ++ show l+      ++ "\nis not relative to the installation prefix:\n"+      ++ show p+  CombinedConstraints dispDepend ->+    render $+      text "The following package dependencies were requested"+        $+$ nest 4 dispDepend+        $+$ text "however the given installed package instance does not exist."+  CantParseGHCOutput -> "Can't parse --info output of GHC"+  IncompatibleWithCabal compilerName packagePathEnvVar ->+    "Use of "+      ++ compilerName+      ++ "'s environment variable "+      ++ packagePathEnvVar+      ++ " is incompatible with Cabal. Use the "+      ++ "flag --package-db to specify a package database (it can be "+      ++ "used multiple times)."+  Couldn'tFindTestProgram cmd ->+    "Could not find test program \""+      ++ cmd+      ++ "\". Did you build the package first?"+  TestCoverageSupport -> "Test coverage is only supported for packages with a library component."+  Couldn'tFindTestProgLibV09 cmd ->+    "Could not find test program \""+      ++ cmd+      ++ "\". Did you build the package first?"+  TestCoverageSupportLibV09 -> "Test coverage is only supported for packages with a library component."+  RawSystemStdout errors -> errors+  FindFile fileName -> fileName ++ " doesn't exist"+  FindModuleFileEx mod_name extensions searchPath ->+    "Could not find module: "+      ++ prettyShow mod_name+      ++ " with any suffix: "+      ++ show (map prettyShow extensions)+      ++ " in the search path: "+      ++ show searchPath+  MultipleFilesWithExtension buildInfoExt -> "Multiple files with extension " ++ buildInfoExt+  NoDesc ->+    "No cabal file found.\n"+      ++ "Please create a package description file <pkgname>.cabal"+  MultiDesc l ->+    "Multiple cabal files found.\n"+      ++ "Please use only one of: "+      ++ intercalate ", " l+  RelocRegistrationInfo ->+    "Distribution.Simple.Register.relocRegistrationInfo: \+    \not implemented for this compiler"+  CreatePackageDB ->+    "Distribution.Simple.Register.createPackageDB: "+      ++ "not implemented for this compiler"+  WithHcPkg name ->+    "Distribution.Simple.Register."+      ++ name+      ++ ":\+         \not implemented for this compiler"+  RegisMultiplePkgNotSupported -> "Registering multiple package instances is not yet supported for this compiler"+  RegisteringNotImplemented -> "Registering is not implemented for this compiler"+  NoTestSuitesEnabled ->+    "No test suites enabled. Did you remember to 'Setup configure' with "+      ++ "\'--enable-tests\'?"+  TestNameDisabled tName ->+    "Package configured with test suite "+      ++ tName+      ++ " disabled."+  NoSuchTest tName -> "no such test: " ++ tName+  ConfigureProgram name path ->+    "Cannot find the program '"+      ++ name+      ++ "'. User-specified path '"+      ++ path+      ++ "' does not refer to an executable and "+      ++ "the program is not on the system path."+  RequireProgram progName -> "The program '" ++ progName ++ "' is required but it could not be found."+  NoProgramFound progName versionRange ->+    "The program '"+      ++ progName+      ++ "'"+      ++ versionRequirement versionRange+      ++ " is required but it could not be found."+  BadVersionDb progName version range locationPath ->+    "The program '"+      ++ progName+      ++ "'"+      ++ versionRequirement range+      ++ " is required but the version found at "+      ++ locationPath+      ++ " is version "+      ++ prettyShow version+  UnknownVersionDb progName versionRange locationPath ->+    "The program '"+      ++ progName+      ++ "'"+      ++ versionRequirement versionRange+      ++ " is required but the version of "+      ++ locationPath+      ++ " could not be determined."+  MissingCoveredInstalledLibrary unitId ->+    "Failed to find the installed unit '"+      ++ prettyShow unitId+      ++ "' in package database stack."+  SetupHooksException err ->+    setupHooksExceptionMessage err+  MultiReplDoesNotSupportComplexReexportedModules pname cname ->+    "When attempting start the repl for "+      ++ showComponentName cname+      ++ " from package "+      ++ prettyShow pname+      ++ " a module renaming was found.\n"+      ++ "Multi-repl does not work with complicated reexported-modules until GHC-9.12."
+ src/Distribution/Simple/FileMonitor/Types.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module: Distribution.Simple.FileMonitor.Types+--+-- Types for monitoring files and directories.+module Distribution.Simple.FileMonitor.Types+  ( -- * Globs with respect to a root+    RootedGlob (..)+  , FilePathRoot (..)+  , Glob++    -- * File monitoring+  , MonitorFilePath (..)+  , MonitorKindFile (..)+  , MonitorKindDir (..)++    -- ** Utility constructors of t'MonitorFilePath'+  , monitorFile+  , monitorFileHashed+  , monitorNonExistentFile+  , monitorFileExistence+  , monitorDirectory+  , monitorNonExistentDirectory+  , monitorDirectoryExistence+  , monitorFileOrDirectory+  , monitorFileGlob+  , monitorFileGlobExistence+  , monitorFileSearchPath+  , monitorFileHashedSearchPath+  )+where++import Distribution.Compat.Prelude+import Distribution.Simple.Glob.Internal+  ( Glob (..)+  )++import qualified Distribution.Compat.CharParsing as P+import Distribution.Parsec+import Distribution.Pretty+import qualified Text.PrettyPrint as Disp++--------------------------------------------------------------------------------+-- Rooted globs.+--++-- | A file path specified by globbing, relative+-- to some root directory.+data RootedGlob+  = RootedGlob+      FilePathRoot+      -- ^ what the glob is relative to+      Glob+      -- ^ the glob+  deriving (Eq, Show, Generic)++instance Binary RootedGlob+instance Structured RootedGlob++data FilePathRoot+  = FilePathRelative+  | -- | e.g. @"/"@, @"c:\"@ or result of 'takeDrive'+    FilePathRoot FilePath+  | FilePathHomeDir+  deriving (Eq, Show, Generic)++instance Binary FilePathRoot+instance Structured FilePathRoot++------------------------------------------------------------------------------+-- Types for specifying files to monitor+--++-- | A description of a file (or set of files) to monitor for changes.+--+-- Where file paths are relative they are relative to a common directory+-- (e.g. project root), not necessarily the process current directory.+data MonitorFilePath+  = MonitorFile+      { monitorKindFile :: !MonitorKindFile+      , monitorKindDir :: !MonitorKindDir+      , monitorPath :: !FilePath+      }+  | MonitorFileGlob+      { monitorKindFile :: !MonitorKindFile+      , monitorKindDir :: !MonitorKindDir+      , monitorPathGlob :: !RootedGlob+      }+  deriving (Eq, Show, Generic)++data MonitorKindFile+  = FileExists+  | FileModTime+  | FileHashed+  | FileNotExists+  deriving (Eq, Show, Generic)++data MonitorKindDir+  = DirExists+  | DirModTime+  | DirNotExists+  deriving (Eq, Show, Generic)++instance Binary MonitorFilePath+instance Binary MonitorKindFile+instance Binary MonitorKindDir++instance Structured MonitorFilePath+instance Structured MonitorKindFile+instance Structured MonitorKindDir++-- | Monitor a single file for changes, based on its modification time.+-- The monitored file is considered to have changed if it no longer+-- exists or if its modification time has changed.+monitorFile :: FilePath -> MonitorFilePath+monitorFile = MonitorFile FileModTime DirNotExists++-- | Monitor a single file for changes, based on its modification time+-- and content hash. The monitored file is considered to have changed if+-- it no longer exists or if its modification time and content hash have+-- changed.+monitorFileHashed :: FilePath -> MonitorFilePath+monitorFileHashed = MonitorFile FileHashed DirNotExists++-- | Monitor a single non-existent file for changes. The monitored file+-- is considered to have changed if it exists.+monitorNonExistentFile :: FilePath -> MonitorFilePath+monitorNonExistentFile = MonitorFile FileNotExists DirNotExists++-- | Monitor a single file for existence only. The monitored file is+-- considered to have changed if it no longer exists.+monitorFileExistence :: FilePath -> MonitorFilePath+monitorFileExistence = MonitorFile FileExists DirNotExists++-- | Monitor a single directory for changes, based on its modification+-- time. The monitored directory is considered to have changed if it no+-- longer exists or if its modification time has changed.+monitorDirectory :: FilePath -> MonitorFilePath+monitorDirectory = MonitorFile FileNotExists DirModTime++-- | Monitor a single non-existent directory for changes.  The monitored+-- directory is considered to have changed if it exists.+monitorNonExistentDirectory :: FilePath -> MonitorFilePath+-- Just an alias for monitorNonExistentFile, since you can't+-- tell the difference between a non-existent directory and+-- a non-existent file :)+monitorNonExistentDirectory = monitorNonExistentFile++-- | Monitor a single directory for existence. The monitored directory is+-- considered to have changed only if it no longer exists.+monitorDirectoryExistence :: FilePath -> MonitorFilePath+monitorDirectoryExistence = MonitorFile FileNotExists DirExists++-- | Monitor a single file or directory for changes, based on its modification+-- time. The monitored file is considered to have changed if it no longer+-- exists or if its modification time has changed.+monitorFileOrDirectory :: FilePath -> MonitorFilePath+monitorFileOrDirectory = MonitorFile FileModTime DirModTime++-- | Monitor a set of files (or directories) identified by a file glob.+-- The monitored glob is considered to have changed if the set of files+-- matching the glob changes (i.e. creations or deletions), or for files if the+-- modification time and content hash of any matching file has changed.+monitorFileGlob :: RootedGlob -> MonitorFilePath+monitorFileGlob = MonitorFileGlob FileHashed DirExists++-- | Monitor a set of files (or directories) identified by a file glob for+-- existence only. The monitored glob is considered to have changed if the set+-- of files matching the glob changes (i.e. creations or deletions).+monitorFileGlobExistence :: RootedGlob -> MonitorFilePath+monitorFileGlobExistence = MonitorFileGlob FileExists DirExists++-- | Creates a list of files to monitor when you search for a file which+-- unsuccessfully looked in @notFoundAtPaths@ before finding it at+-- @foundAtPath@.+monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath]+monitorFileSearchPath notFoundAtPaths foundAtPath =+  monitorFile foundAtPath+    : map monitorNonExistentFile notFoundAtPaths++-- | Similar to 'monitorFileSearchPath', but also instructs us to+-- monitor the hash of the found file.+monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath]+monitorFileHashedSearchPath notFoundAtPaths foundAtPath =+  monitorFileHashed foundAtPath+    : map monitorNonExistentFile notFoundAtPaths++------------------------------------------------------------------------------+-- Parsing & pretty-printing+--++instance Pretty RootedGlob where+  pretty (RootedGlob root pathglob) = pretty root Disp.<> pretty pathglob++instance Parsec RootedGlob where+  parsec = do+    root <- parsec+    case root of+      FilePathRelative -> RootedGlob root <$> parsec+      _ -> RootedGlob root <$> parsec <|> pure (RootedGlob root GlobDirTrailing)++instance Pretty FilePathRoot where+  pretty FilePathRelative = Disp.empty+  pretty (FilePathRoot root) = Disp.text root+  pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/'++instance Parsec FilePathRoot where+  parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative+    where+      root = FilePathRoot "/" <$ P.char '/'+      home = FilePathHomeDir <$ P.string "~/"+      drive = do+        dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')+        _ <- P.char ':'+        _ <- P.char '/' <|> P.char '\\'+        return (FilePathRoot (toUpper dr : ":\\"))
src/Distribution/Simple/Flag.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Flag -- Copyright   :  Isaac Jones 2003-2004@@ -16,117 +17,109 @@ -- for an explanation. -- -- Split off from "Distribution.Simple.Setup" to break import cycles.-module Distribution.Simple.Flag (-  Flag(..),-  allFlags,-  toFlag,-  fromFlag,-  fromFlagOrDefault,-  flagElim,-  flagToMaybe,-  flagToList,-  maybeToFlag,-  BooleanFlag(..) ) where+module Distribution.Simple.Flag+  ( Flag+  , pattern Flag+  , pattern NoFlag+  , allFlags+  , toFlag+  , fromFlag+  , fromFlagOrDefault+  , flagElim+  , flagToMaybe+  , flagToList+  , maybeToFlag+  , mergeListFlag+  , BooleanFlag (..)+  ) where -import Prelude ()+import Data.Monoid (Last (..)) import Distribution.Compat.Prelude hiding (get) import Distribution.Compat.Stack+import Prelude ()  -- ------------------------------------------------------------+ -- * Flag type+ -- ------------------------------------------------------------  -- | All flags are monoids, they come in two flavours: -- -- 1. list flags eg ----- > --ghc-option=foo --ghc-option=bar+--   > --ghc-option=foo --ghc-option=bar ----- gives us all the values ["foo", "bar"]+--   gives us all the values ["foo", "bar"] -- -- 2. singular value flags, eg: ----- > --enable-foo --disable-foo+--   > --enable-foo --disable-foo ----- gives us Just False--- So this Flag type is for the latter singular kind of flag.+--   gives us Just False+--+-- So, this 'Flag' type is for the latter singular kind of flag. -- Its monoid instance gives us the behaviour where it starts out as -- 'NoFlag' and later flags override earlier ones. ---data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Typeable)--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 = (<>)+-- Isomorphic to 'Maybe' a.+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 toFlag = Flag +-- | Extracts a value from a 'Flag', and throws an exception on 'NoFlag'. fromFlag :: WithCallStack (Flag a -> a) fromFlag (Flag x) = x-fromFlag NoFlag   = error "fromFlag NoFlag. Use fromFlagOrDefault"+fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" +-- | 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 --- | @since 3.4.0.0+-- | 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-allFlags flags = if all (\f -> fromFlagOrDefault False f) flags-                 then Flag True-                 else NoFlag+allFlags flags =+  if all (\f -> fromFlagOrDefault False f) flags+    then Flag True+    else NoFlag +-- | 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]+mergeListFlag currentFlags v =+  Flag $ concat (flagToList currentFlags ++ flagToList v)+ -- | Types that represent boolean flags. class BooleanFlag a where-    asBool :: a -> Bool+  asBool :: a -> Bool  instance BooleanFlag Bool where   asBool = id
src/Distribution/Simple/GHC.hs view
@@ -1,2088 +1,1166 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE CPP #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.GHC--- Copyright   :  Isaac Jones 2003-2007--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This is a fairly large module. It contains most of the GHC-specific code for--- configuring, building and installing packages. It also exports a function--- for finding out what packages are already installed. Configuring involves--- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions--- this version of ghc supports and returning a 'Compiler' value.------ 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out--- what packages are installed.------ Building is somewhat complex as there is quite a bit of information to take--- into account. We have to build libs and programs, possibly for profiling and--- shared libs. We have to support building libraries that will be usable by--- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files--- using ghc. Linking, especially for @split-objs@ is remarkably complex,--- partly because there tend to be 1,000's of @.o@ files and this can often be--- more than we can pass to the @ld@ or @ar@ programs in one go.------ Installing for libs and exes involves finding the right files and copying--- them to the right places. One of the more tricky things about this module is--- remembering the layout of files in the build directory (which is not--- explicitly documented) and thus what search dirs are used for various kinds--- of files.--module Distribution.Simple.GHC (-        getGhcInfo,-        configure,-        getInstalledPackages,-        getInstalledPackagesMonitorFiles,-        getPackageDBContents,-        buildLib, buildFLib, buildExe,-        replLib, replFLib, replExe,-        startInterpreter,-        installLib, installFLib, installExe,-        libAbiHash,-        hcPkgInfo,-        registerPackage,-        componentGhcOptions,-        componentCcGhcOptions,-        getGhcAppDir,-        getLibDir,-        isDynamic,-        getGlobalPackageDB,-        pkgRoot,-        -- * Constructing and deconstructing GHC environment files-        Internal.GhcEnvironmentFileEntry(..),-        Internal.simpleGhcEnvironmentFile,-        Internal.renderGhcEnvironmentFile,-        Internal.writeGhcEnvironmentFile,-        Internal.ghcPlatformAndVersionString,-        readGhcEnvironmentFile,-        parseGhcEnvironmentFile,-        ParseErrorExc(..),-        -- * Version-specific implementation quirks-        getImplInfo,-        GhcImplInfo(..)- ) where--import Prelude ()-import Distribution.Compat.Prelude--import qualified Distribution.Simple.GHC.Internal as Internal-import Distribution.CabalSpecVersion-import Distribution.Simple.GHC.ImplInfo-import Distribution.Simple.GHC.EnvironmentParser-import Distribution.PackageDescription.Utils (cabalBug)-import Distribution.PackageDescription as PD-import Distribution.InstalledPackageInfo (InstalledPackageInfo)-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.LocalBuildInfo-import Distribution.Types.ComponentLocalBuildInfo-import qualified Distribution.Simple.Hpc as Hpc-import Distribution.Simple.BuildPaths-import Distribution.Simple.Utils-import Distribution.Package-import qualified Distribution.ModuleName as ModuleName-import Distribution.ModuleName (ModuleName)-import Distribution.Simple.Program-import Distribution.Simple.Program.Builtin (runghcProgram)-import qualified Distribution.Simple.Program.HcPkg as HcPkg-import qualified Distribution.Simple.Program.Ar    as Ar-import qualified Distribution.Simple.Program.Ld    as Ld-import qualified Distribution.Simple.Program.Strip as Strip-import Distribution.Simple.Program.GHC-import Distribution.Simple.Setup-import qualified Distribution.Simple.Setup as Cabal-import Distribution.Simple.Compiler-import Distribution.Version-import Distribution.System-import Distribution.Verbosity-import Distribution.Pretty-import Distribution.Utils.NubList-import Distribution.Utils.Path-import Language.Haskell.Extension--import Control.Monad (msum, forM_)-import Data.Char (isLower)-import qualified Data.Map as Map-import System.Directory-         ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing-         , canonicalizePath, removeFile, renameFile, getDirectoryContents )-import System.FilePath          ( (</>), (<.>), takeExtension-                                , takeDirectory, replaceExtension-                                ,isRelative )-import qualified System.Info-#ifndef mingw32_HOST_OS-import System.Posix (createSymbolicLink)-#endif /* mingw32_HOST_OS */---- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramDb-          -> IO (Compiler, Maybe Platform, ProgramDb)-configure verbosity hcPath hcPkgPath conf0 = do--  (ghcProg, ghcVersion, progdb1) <--    requireProgramVersion verbosity ghcProgram-      (orLaterVersion (mkVersion [7,0,1]))-      (userMaybeSpecifyPath "ghc" hcPath conf0)-  let implInfo = ghcVersionImplInfo ghcVersion--  -- Cabal currently supports ghc >= 7.0.1 && < 9.4-  -- ... and the following odd development version-  unless (ghcVersion < mkVersion [9,4]) $-    warn verbosity $-         "Unknown/unsupported 'ghc' version detected "-      ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 9.4): "-      ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion--  -- This is slightly tricky, we have to configure ghc first, then we use the-  -- location of ghc to help find ghc-pkg in the case that the user did not-  -- specify the location of ghc-pkg directly:-  (ghcPkgProg, ghcPkgVersion, progdb2) <--    requireProgramVersion verbosity ghcPkgProgram {-      programFindLocation = guessGhcPkgFromGhcPath ghcProg-    }-    anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1)--  when (ghcVersion /= ghcPkgVersion) $ die' verbosity $-       "Version mismatch between ghc and ghc-pkg: "-    ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion ++ " "-    ++ programPath ghcPkgProg ++ " is version " ++ prettyShow ghcPkgVersion--  -- 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--  ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg-  let ghcInfoMap = Map.fromList ghcInfo-      extensions = -- workaround https://gitlab.haskell.org/ghc/ghc/-/issues/11214-                   filterExt JavaScriptFFI $-                   -- see 'filterExtTH' comment below-                   filterExtTH $ extensions0--      -- starting with GHC 8.0, `TemplateHaskell` will be omitted from-      -- `--supported-extensions` when it's not available.-      -- for older GHCs we can use the "Have interpreter" property to-      -- filter out `TemplateHaskell`-      filterExtTH | ghcVersion < mkVersion [8]-                   , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap-                   = filterExt TemplateHaskell-                  | otherwise = id--      filterExt ext = filter ((/= EnableExtension ext) . fst)--  let comp = Compiler {-        compilerId         = CompilerId GHC ghcVersion,-        compilerAbiTag     = NoAbiTag,-        compilerCompat     = [],-        compilerLanguages  = languages,-        compilerExtensions = extensions,-        compilerProperties = ghcInfoMap-      }-      compPlatform = Internal.targetPlatform ghcInfo-      -- configure gcc and ld-      progdb4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap progdb3-  return (comp, compPlatform, 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:------ > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe)--- > /usr/local/bin/ghc-pkg-6.6.1(.exe)--- > /usr/local/bin/ghc-pkg(.exe)----guessToolFromGhcPath :: Program -> ConfiguredProgram-                     -> Verbosity -> ProgramSearchPath-                     -> IO (Maybe (FilePath, [FilePath]))-guessToolFromGhcPath tool ghcProg verbosity searchpath-  = do let toolname          = programName tool-           given_path        = programPath ghcProg-           given_dir         = takeDirectory given_path-       real_path <- canonicalizePath given_path-       let real_dir           = takeDirectory real_path-           versionSuffix path = takeVersionSuffix (dropExeExtension path)-           given_suf = versionSuffix given_path-           real_suf  = versionSuffix real_path-           guessNormal       dir = dir </> toolname <.> exeExtension buildPlatform-           guessGhcVersioned dir suf = dir </> (toolname ++ "-ghc" ++ suf)-                                           <.> exeExtension buildPlatform-           guessVersioned    dir suf = dir </> (toolname ++ suf)-                                           <.> exeExtension buildPlatform-           mkGuesses dir suf | null suf  = [guessNormal dir]-                             | otherwise = [guessGhcVersioned dir suf,-                                            guessVersioned dir suf,-                                            guessNormal dir]-           -- order matters here, see https://github.com/haskell/cabal/issues/7390-           guesses = (if real_path == given_path-                        then []-                        else mkGuesses real_dir real_suf)-                     ++ mkGuesses given_dir given_suf-       info verbosity $ "looking for tool " ++ toolname-         ++ " near compiler in " ++ given_dir-       debug verbosity $ "candidate locations: " ++ show guesses-       exists <- traverse doesFileExist guesses-       case [ file | (file, True) <- zip guesses exists ] of-                   -- If we can't find it near ghc, fall back to the usual-                   -- method.-         []     -> programFindLocation tool verbosity searchpath-         (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp-                      let lookedAt = map fst-                                   . takeWhile (\(_file, exist) -> not exist)-                                   $ zip guesses exists-                      return (Just (fp, lookedAt))--  where takeVersionSuffix :: FilePath -> String-        takeVersionSuffix = takeWhileEndLE isSuffixChar--        isSuffixChar :: Char -> Bool-        isSuffixChar c = isDigit c || c == '.' || c == '-'---- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a--- corresponding ghc-pkg, we try looking for both a versioned and unversioned--- ghc-pkg in the same dir, that is:------ > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe)--- > /usr/local/bin/ghc-pkg-6.6.1(.exe)--- > /usr/local/bin/ghc-pkg(.exe)----guessGhcPkgFromGhcPath :: ConfiguredProgram-                       -> Verbosity -> ProgramSearchPath-                       -> IO (Maybe (FilePath, [FilePath]))-guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram---- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a--- corresponding hsc2hs, we try looking for both a versioned and unversioned--- hsc2hs in the same dir, that is:------ > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe)--- > /usr/local/bin/hsc2hs-6.6.1(.exe)--- > /usr/local/bin/hsc2hs(.exe)----guessHsc2hsFromGhcPath :: ConfiguredProgram-                       -> Verbosity -> ProgramSearchPath-                       -> IO (Maybe (FilePath, [FilePath]))-guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram---- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a--- corresponding haddock, we try looking for both a versioned and unversioned--- haddock in the same dir, that is:------ > /usr/local/bin/haddock-ghc-6.6.1(.exe)--- > /usr/local/bin/haddock-6.6.1(.exe)--- > /usr/local/bin/haddock(.exe)----guessHaddockFromGhcPath :: ConfiguredProgram-                       -> Verbosity -> ProgramSearchPath-                       -> IO (Maybe (FilePath, [FilePath]))-guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram--guessHpcFromGhcPath :: ConfiguredProgram-                       -> Verbosity -> ProgramSearchPath-                       -> IO (Maybe (FilePath, [FilePath]))-guessHpcFromGhcPath = guessToolFromGhcPath hpcProgram--guessRunghcFromGhcPath :: ConfiguredProgram-                       -> Verbosity -> ProgramSearchPath-                       -> IO (Maybe (FilePath, [FilePath]))-guessRunghcFromGhcPath = guessToolFromGhcPath runghcProgram---getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]-getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg-  where-    version = fromMaybe (error "GHC.getGhcInfo: no ghc version") $ programVersion ghcProg-    implInfo = ghcVersionImplInfo version---- | Given a single package DB, return all installed packages.-getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb-                        -> IO InstalledPackageIndex-getPackageDBContents verbosity packagedb progdb = do-  pkgss <- getInstalledPackages' verbosity [packagedb] progdb-  toPackageIndex verbosity pkgss progdb---- | Given a package DB stack, return all installed packages.-getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack-                     -> ProgramDb-                     -> IO InstalledPackageIndex-getInstalledPackages verbosity comp packagedbs progdb = do-  checkPackageDbEnvVar verbosity-  checkPackageDbStack verbosity comp packagedbs-  pkgss <- getInstalledPackages' verbosity packagedbs progdb-  index <- toPackageIndex verbosity pkgss progdb-  return $! hackRtsPackage index--  where-    hackRtsPackage index =-      case PackageIndex.lookupPackageName index (mkPackageName "rts") of-        [(_,[rts])]-           -> PackageIndex.insert (removeMingwIncludeDir rts) index-        _  -> index -- No (or multiple) ghc rts package is registered!!-                    -- Feh, whatever, the ghc test suite does some crazy stuff.---- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a--- @PackageIndex@. Helper function used by 'getPackageDBContents' and--- 'getInstalledPackages'.-toPackageIndex :: Verbosity-               -> [(PackageDB, [InstalledPackageInfo])]-               -> ProgramDb-               -> IO InstalledPackageIndex-toPackageIndex verbosity pkgss progdb = do-  -- On Windows, various fields have $topdir/foo rather than full-  -- paths. We need to substitute the right value in so that when-  -- we, for example, call gcc, we have proper paths to give it.-  topDir <- getLibDir' verbosity ghcProg-  let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)-                | (_, pkgs) <- pkgss ]-  return $! mconcat indices--  where-    ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb---- | Return the 'FilePath' to the GHC application data directory.------ @since 3.4.0.0-getGhcAppDir :: IO FilePath-getGhcAppDir = getAppUserDataDirectory "ghc"--getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath-getLibDir verbosity lbi =-    dropWhileEndLE isSpace `fmap`-     getDbProgramOutput verbosity ghcProgram-     (withPrograms lbi) ["--print-libdir"]--getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath-getLibDir' verbosity ghcProg =-    dropWhileEndLE isSpace `fmap`-     getProgramOutput verbosity ghcProg ["--print-libdir"]----- | Return the 'FilePath' to the global GHC package database.-getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath-getGlobalPackageDB verbosity ghcProg =-    dropWhileEndLE isSpace `fmap`-     getProgramOutput verbosity ghcProg ["--print-global-package-db"]---- | Return the 'FilePath' to the per-user GHC package database.-getUserPackageDB-  :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath-getUserPackageDB _verbosity ghcProg platform = do-    -- It's rather annoying that we have to reconstruct this, because ghc-    -- hides this information from us otherwise. But for certain use cases-    -- like change monitoring it really can't remain hidden.-    appdir <- getGhcAppDir-    return (appdir </> platformAndVersion </> packageConfFileName)-  where-    platformAndVersion = Internal.ghcPlatformAndVersionString-                           platform ghcVersion-    packageConfFileName = "package.conf.d"-    ghcVersion = fromMaybe (error "GHC.getUserPackageDB: no ghc version") $ programVersion ghcProg--checkPackageDbEnvVar :: Verbosity -> IO ()-checkPackageDbEnvVar verbosity =-    Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH"--checkPackageDbStack :: Verbosity -> Compiler -> PackageDBStack -> IO ()-checkPackageDbStack verbosity comp =-    if flagPackageConf implInfo-      then checkPackageDbStackPre76 verbosity-      else checkPackageDbStackPost76 verbosity-  where implInfo = ghcVersionImplInfo (compilerVersion comp)--checkPackageDbStackPost76 :: Verbosity -> PackageDBStack -> IO ()-checkPackageDbStackPost76 _ (GlobalPackageDB:rest)-  | GlobalPackageDB `notElem` rest = return ()-checkPackageDbStackPost76 verbosity rest-  | GlobalPackageDB `elem` rest =-  die' verbosity $ "If the global package db is specified, it must be "-     ++ "specified first and cannot be specified multiple times"-checkPackageDbStackPost76 _ _ = return ()--checkPackageDbStackPre76 :: Verbosity -> PackageDBStack -> IO ()-checkPackageDbStackPre76 _ (GlobalPackageDB:rest)-  | GlobalPackageDB `notElem` rest = return ()-checkPackageDbStackPre76 verbosity rest-  | GlobalPackageDB `notElem` rest =-  die' verbosity $-        "With current ghc versions the global package db is always used "-     ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6,"-     ++ "see https://gitlab.haskell.org/ghc/ghc/-/issues/5977"-checkPackageDbStackPre76 verbosity _ =-  die' verbosity $ "If the global package db is specified, it must be "-     ++ "specified first and cannot be specified multiple times"---- 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' }---- | Get the packages from specific PackageDBs, not cumulative.----getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb-                     -> IO [(PackageDB, [InstalledPackageInfo])]-getInstalledPackages' verbosity packagedbs progdb =-  sequenceA-    [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb-         return (packagedb, pkgs)-    | packagedb <- packagedbs ]--getInstalledPackagesMonitorFiles :: Verbosity -> Platform-                                 -> ProgramDb-                                 -> [PackageDB]-                                 -> IO [FilePath]-getInstalledPackagesMonitorFiles verbosity platform progdb =-    traverse getPackageDBPath-  where-    getPackageDBPath :: PackageDB -> IO FilePath-    getPackageDBPath GlobalPackageDB =-      selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg--    getPackageDBPath UserPackageDB =-      selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform--    getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path--    -- GHC has old style file dbs, and new style directory dbs.-    -- Note that for dir style dbs, we only need to monitor the cache file, not-    -- the whole directory. The ghc program itself only reads the cache file-    -- so it's safe to only monitor this one file.-    selectMonitorFile path = do-      isFileStyle <- doesFileExist path-      if isFileStyle then return path-                     else return (path </> "package.cache")--    ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb----- -------------------------------------------------------------------------------- Building a library--buildLib :: Verbosity          -> Cabal.Flag (Maybe Int)-         -> PackageDescription -> LocalBuildInfo-         -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib = buildOrReplLib Nothing--replLib :: [String]                -> Verbosity-        -> Cabal.Flag (Maybe Int)  -> PackageDescription-        -> LocalBuildInfo          -> Library-        -> ComponentLocalBuildInfo -> IO ()-replLib = buildOrReplLib . Just--buildOrReplLib :: Maybe [String] -> Verbosity-               -> Cabal.Flag (Maybe Int) -> PackageDescription-               -> LocalBuildInfo -> Library-               -> ComponentLocalBuildInfo -> IO ()-buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do-  let uid = componentUnitId clbi-      libTargetDir = componentBuildDir lbi clbi-      whenVanillaLib forceVanilla =-        when (forceVanilla || withVanillaLib lbi)-      whenProfLib = when (withProfLib lbi)-      whenSharedLib forceShared =-        when (forceShared || withSharedLib lbi)-      whenStaticLib forceStatic =-        when (forceStatic || withStaticLib lbi)-      whenGHCiLib = when (withGHCiLib lbi)-      forRepl = maybe False (const True) mReplFlags-      whenReplLib = when forRepl-      replFlags = fromMaybe mempty mReplFlags-      comp = compiler lbi-      ghcVersion = compilerVersion comp-      implInfo  = getImplInfo comp-      platform@(Platform _hostArch hostOS) = hostPlatform lbi-      has_code = not (componentIsIndefinite clbi)--  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)-  let runGhcProg = runGHC verbosity ghcProg comp platform--  let libBi = libBuildInfo lib--  let isGhcDynamic        = isDynamic comp-      dynamicTooSupported = supportsDynamicToo comp-      doingTH = usesTemplateHaskellOrQQ libBi-      forceVanillaLib = doingTH && not isGhcDynamic-      forceSharedLib  = doingTH &&     isGhcDynamic-      -- TH always needs default libs, even when building for profiling--  -- Determine if program coverage should be enabled and if so, what-  -- '-hpcdir' should be.-  let isCoverageEnabled = libCoverage lbi-      -- TODO: Historically HPC files have been put into a directory which-      -- has the package name.  I'm going to avoid changing this for-      -- now, but it would probably be better for this to be the-      -- component ID instead...-      pkg_name = prettyShow (PD.package pkg_descr)-      distPref = fromFlag $ configDistPref $ configFlags lbi-      hpcdir way-        | forRepl = mempty  -- HPC is not supported in ghci-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name-        | otherwise = mempty--  createDirectoryIfMissingVerbose verbosity True libTargetDir-  -- TODO: do we need to put hs-boot files into place for mutually recursive-  -- modules?-  let cLikeSources  = fromNubListR $ mconcat-                      [ toNubListR (cSources   libBi)-                      , toNubListR (cxxSources libBi)-                      , toNubListR (cmmSources libBi)-                      , toNubListR (asmSources libBi)-                      ]-      cLikeObjs   = map (`replaceExtension` objExtension) cLikeSources-      baseOpts    = componentGhcOptions verbosity lbi libBi clbi libTargetDir-      vanillaOpts = baseOpts `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeMake,-                      ghcOptNumJobs      = numJobs,-                      ghcOptInputModules = toNubListR $ allLibModules lib clbi,-                      ghcOptHPCDir       = hpcdir Hpc.Vanilla-                    }--      profOpts    = vanillaOpts `mappend` mempty {-                      ghcOptProfilingMode = toFlag True,-                      ghcOptProfilingAuto = Internal.profDetailLevelFlag True-                                              (withProfLibDetail lbi),-                      ghcOptHiSuffix      = toFlag "p_hi",-                      ghcOptObjSuffix     = toFlag "p_o",-                      ghcOptExtra         = hcProfOptions GHC libBi,-                      ghcOptHPCDir        = hpcdir Hpc.Prof-                    }--      sharedOpts  = vanillaOpts `mappend` mempty {-                      ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                      ghcOptFPic        = toFlag True,-                      ghcOptHiSuffix    = toFlag "dyn_hi",-                      ghcOptObjSuffix   = toFlag "dyn_o",-                      ghcOptExtra       = hcSharedOptions GHC libBi,-                      ghcOptHPCDir      = hpcdir Hpc.Dyn-                    }-      linkerOpts = mempty {-                      ghcOptLinkOptions       = PD.ldOptions libBi-                                                ++ [ "-static"-                                                   | withFullyStaticExe lbi ]-                                                -- Pass extra `ld-options` given-                                                -- through to GHC's linker.-                                                ++ maybe [] programOverrideArgs-                                                     (lookupProgram ldProgram (withPrograms lbi)),-                      ghcOptLinkLibs          = extraLibs libBi,-                      ghcOptLinkLibPath       = toNubListR $ extraLibDirs libBi,-                      ghcOptLinkFrameworks    = toNubListR $ PD.frameworks libBi,-                      ghcOptLinkFrameworkDirs = toNubListR $-                                                PD.extraFrameworkDirs libBi,-                      ghcOptInputFiles     = toNubListR-                                             [libTargetDir </> x | x <- cLikeObjs]-                   }-      replOpts    = vanillaOpts {-                      ghcOptExtra        = Internal.filterGhciFlags-                                           (ghcOptExtra vanillaOpts)-                                           <> replFlags,-                      ghcOptNumJobs      = mempty-                    }-                    `mappend` linkerOpts-                    `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeInteractive,-                      ghcOptOptimisation = toFlag GhcNoOptimisation-                    }--      vanillaSharedOpts = vanillaOpts `mappend` mempty {-                      ghcOptDynLinkMode  = toFlag GhcStaticAndDynamic,-                      ghcOptDynHiSuffix  = toFlag "dyn_hi",-                      ghcOptDynObjSuffix = toFlag "dyn_o",-                      ghcOptHPCDir       = hpcdir Hpc.Dyn-                    }--  unless (forRepl || null (allLibModules lib clbi)) $-    do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts)-           shared  = whenSharedLib  forceSharedLib  (runGhcProg sharedOpts)-           useDynToo = dynamicTooSupported &&-                       (forceVanillaLib || withVanillaLib lbi) &&-                       (forceSharedLib  || withSharedLib  lbi) &&-                       null (hcSharedOptions GHC libBi)-       if not has_code-        then vanilla-        else-         if useDynToo-          then do-              runGhcProg vanillaSharedOpts-              case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of-                (Cabal.Flag dynDir, Cabal.Flag vanillaDir) ->-                    -- When the vanilla and shared library builds are done-                    -- in one pass, only one set of HPC module interfaces-                    -- are generated. This set should suffice for both-                    -- static and dynamically linked executables. We copy-                    -- the modules interfaces so they are available under-                    -- both ways.-                    copyDirectoryRecursive verbosity dynDir vanillaDir-                _ -> return ()-          else if isGhcDynamic-            then do shared;  vanilla-            else do vanilla; shared-       whenProfLib (runGhcProg profOpts)--  -- Build any C++ sources separately.-  unless (not has_code || null (cxxSources libBi)) $ do-    info verbosity "Building C++ Sources..."-    sequence_-      [ do let baseCxxOpts    = Internal.componentCxxGhcOptions verbosity implInfo-                                lbi libBi clbi libTargetDir filename-               vanillaCxxOpts = if isGhcDynamic-                                then baseCxxOpts { ghcOptFPic = toFlag True }-                                else baseCxxOpts-               profCxxOpts    = vanillaCxxOpts `mappend` mempty {-                                  ghcOptProfilingMode = toFlag True,-                                  ghcOptObjSuffix     = toFlag "p_o"-                                }-               sharedCxxOpts  = vanillaCxxOpts `mappend` mempty {-                                 ghcOptFPic        = toFlag True,-                                 ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                                 ghcOptObjSuffix   = toFlag "dyn_o"-                               }-               odir           = fromFlag (ghcOptObjDir vanillaCxxOpts)-           createDirectoryIfMissingVerbose verbosity True odir-           let runGhcProgIfNeeded cxxOpts = do-                 needsRecomp <- checkNeedsRecompilation filename cxxOpts-                 when needsRecomp $ runGhcProg cxxOpts-           runGhcProgIfNeeded vanillaCxxOpts-           unless forRepl $-             whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts)-           unless forRepl $ whenProfLib   (runGhcProgIfNeeded   profCxxOpts)-      | filename <- cxxSources libBi]--  -- build any C sources-  unless (not has_code || null (cSources libBi)) $ do-    info verbosity "Building C Sources..."-    sequence_-      [ do let baseCcOpts    = Internal.componentCcGhcOptions verbosity implInfo-                               lbi libBi clbi libTargetDir filename-               vanillaCcOpts = if isGhcDynamic-                               -- Dynamic GHC requires C sources to be built-                               -- with -fPIC for REPL to work. See #2207.-                               then baseCcOpts { ghcOptFPic = toFlag True }-                               else baseCcOpts-               profCcOpts    = vanillaCcOpts `mappend` mempty {-                                 ghcOptProfilingMode = toFlag True,-                                 ghcOptObjSuffix     = toFlag "p_o"-                               }-               sharedCcOpts  = vanillaCcOpts `mappend` mempty {-                                 ghcOptFPic        = toFlag True,-                                 ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                                 ghcOptObjSuffix   = toFlag "dyn_o"-                               }-               odir          = fromFlag (ghcOptObjDir vanillaCcOpts)-           createDirectoryIfMissingVerbose verbosity True odir-           let runGhcProgIfNeeded ccOpts = do-                 needsRecomp <- checkNeedsRecompilation filename ccOpts-                 when needsRecomp $ runGhcProg ccOpts-           runGhcProgIfNeeded vanillaCcOpts-           unless forRepl $-             whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts)-           unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts)-      | filename <- cSources libBi]--  -- build any ASM sources-  unless (not has_code || null (asmSources libBi)) $ do-    info verbosity "Building Assembler Sources..."-    sequence_-      [ do let baseAsmOpts    = Internal.componentAsmGhcOptions verbosity implInfo-                                lbi libBi clbi libTargetDir filename-               vanillaAsmOpts = if isGhcDynamic-                                -- Dynamic GHC requires objects to be built-                                -- with -fPIC for REPL to work. See #2207.-                                then baseAsmOpts { ghcOptFPic = toFlag True }-                                else baseAsmOpts-               profAsmOpts    = vanillaAsmOpts `mappend` mempty {-                                 ghcOptProfilingMode = toFlag True,-                                 ghcOptObjSuffix     = toFlag "p_o"-                               }-               sharedAsmOpts  = vanillaAsmOpts `mappend` mempty {-                                 ghcOptFPic        = toFlag True,-                                 ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                                 ghcOptObjSuffix   = toFlag "dyn_o"-                               }-               odir           = fromFlag (ghcOptObjDir vanillaAsmOpts)-           createDirectoryIfMissingVerbose verbosity True odir-           let runGhcProgIfNeeded asmOpts = do-                 needsRecomp <- checkNeedsRecompilation filename asmOpts-                 when needsRecomp $ runGhcProg asmOpts-           runGhcProgIfNeeded vanillaAsmOpts-           unless forRepl $-             whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedAsmOpts)-           unless forRepl $ whenProfLib (runGhcProgIfNeeded profAsmOpts)-      | filename <- asmSources libBi]--  -- build any Cmm sources-  unless (not has_code || null (cmmSources libBi)) $ do-    info verbosity "Building C-- Sources..."-    sequence_-      [ do let baseCmmOpts    = Internal.componentCmmGhcOptions verbosity implInfo-                                lbi libBi clbi libTargetDir filename-               vanillaCmmOpts = if isGhcDynamic-                                -- Dynamic GHC requires C sources to be built-                                -- with -fPIC for REPL to work. See #2207.-                                then baseCmmOpts { ghcOptFPic = toFlag True }-                                else baseCmmOpts-               profCmmOpts    = vanillaCmmOpts `mappend` mempty {-                                 ghcOptProfilingMode = toFlag True,-                                 ghcOptObjSuffix     = toFlag "p_o"-                               }-               sharedCmmOpts  = vanillaCmmOpts `mappend` mempty {-                                 ghcOptFPic        = toFlag True,-                                 ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                                 ghcOptObjSuffix   = toFlag "dyn_o"-                               }-               odir          = fromFlag (ghcOptObjDir vanillaCmmOpts)-           createDirectoryIfMissingVerbose verbosity True odir-           let runGhcProgIfNeeded cmmOpts = do-                 needsRecomp <- checkNeedsRecompilation filename cmmOpts-                 when needsRecomp $ runGhcProg cmmOpts-           runGhcProgIfNeeded vanillaCmmOpts-           unless forRepl $-             whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCmmOpts)-           unless forRepl $ whenProfLib (runGhcProgIfNeeded profCmmOpts)-      | filename <- cmmSources libBi]--  -- TODO: problem here is we need the .c files built first, so we can load them-  -- with ghci, but .c files can depend on .h files generated by ghc by ffi-  -- exports.-  whenReplLib $ do-    when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules"-    runGhcProg replOpts--  -- link:-  when has_code . unless forRepl $ do-    info verbosity "Linking..."-    let cLikeProfObjs        = map (`replaceExtension` ("p_" ++ objExtension))-                               cLikeSources-        cLikeSharedObjs      = map (`replaceExtension` ("dyn_" ++ objExtension))-                               cLikeSources-        compiler_id          = compilerId (compiler lbi)-        vanillaLibFilePath   = libTargetDir </> mkLibName uid-        profileLibFilePath   = libTargetDir </> mkProfLibName uid-        sharedLibFilePath    = libTargetDir </>-                               mkSharedLibName (hostPlatform lbi) compiler_id uid-        staticLibFilePath    = libTargetDir </>-                               mkStaticLibName (hostPlatform lbi) compiler_id uid-        ghciLibFilePath      = libTargetDir </> Internal.mkGHCiLibName uid-        ghciProfLibFilePath  = libTargetDir </> Internal.mkGHCiProfLibName uid-        libInstallPath       = libdir $-                               absoluteComponentInstallDirs-                               pkg_descr lbi uid NoCopyDest-        sharedLibInstallPath = libInstallPath </>-                               mkSharedLibName (hostPlatform lbi) compiler_id uid--    stubObjs <- catMaybes <$> sequenceA-      [ findFileWithExtension [objExtension] [libTargetDir]-          (ModuleName.toFilePath x ++"_stub")-      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files-      , x <- allLibModules lib clbi ]-    stubProfObjs <- catMaybes <$> sequenceA-      [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]-          (ModuleName.toFilePath x ++"_stub")-      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files-      , x <- allLibModules lib clbi ]-    stubSharedObjs <- catMaybes <$> sequenceA-      [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]-          (ModuleName.toFilePath x ++"_stub")-      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files-      , x <- allLibModules lib clbi ]--    hObjs     <- Internal.getHaskellObjects implInfo lib lbi clbi-                      libTargetDir objExtension True-    hProfObjs <--      if withProfLib lbi-              then Internal.getHaskellObjects implInfo lib lbi clbi-                      libTargetDir ("p_" ++ objExtension) True-              else return []-    hSharedObjs <--      if withSharedLib lbi-              then Internal.getHaskellObjects implInfo lib lbi clbi-                      libTargetDir ("dyn_" ++ objExtension) False-              else return []--    unless (null hObjs && null cLikeObjs && null stubObjs) $ do-      rpaths <- getRPaths lbi clbi--      let staticObjectFiles =-                 hObjs-              ++ map (libTargetDir </>) cLikeObjs-              ++ stubObjs-          profObjectFiles =-                 hProfObjs-              ++ map (libTargetDir </>) cLikeProfObjs-              ++ stubProfObjs-          dynamicObjectFiles =-                 hSharedObjs-              ++ map (libTargetDir </>) cLikeSharedObjs-              ++ stubSharedObjs-          -- After the relocation lib is created we invoke ghc -shared-          -- with the dependencies spelled out as -package arguments-          -- and ghc invokes the linker with the proper library paths-          ghcSharedLinkArgs =-              mempty {-                ghcOptShared             = toFlag True,-                ghcOptDynLinkMode        = toFlag GhcDynamicOnly,-                ghcOptInputFiles         = toNubListR dynamicObjectFiles,-                ghcOptOutputFile         = toFlag sharedLibFilePath,-                ghcOptExtra              = hcSharedOptions GHC libBi,-                -- For dynamic libs, Mac OS/X needs to know the install location-                -- at build time. This only applies to GHC < 7.8 - see the-                -- discussion in #1660.-                ghcOptDylibName          = if hostOS == OSX-                                              && ghcVersion < mkVersion [7,8]-                                            then toFlag sharedLibInstallPath-                                            else mempty,-                ghcOptHideAllPackages    = toFlag True,-                ghcOptNoAutoLinkPackages = toFlag True,-                ghcOptPackageDBs         = withPackageDB lbi,-                ghcOptThisUnitId = case clbi of-                    LibComponentLocalBuildInfo { componentCompatPackageKey = pk }-                      -> toFlag pk-                    _ -> mempty,-                ghcOptThisComponentId = case clbi of-                    LibComponentLocalBuildInfo-                      { componentInstantiatedWith = insts } ->-                        if null insts-                            then mempty-                            else toFlag (componentComponentId clbi)-                    _ -> mempty,-                ghcOptInstantiatedWith = case clbi of-                    LibComponentLocalBuildInfo-                      { componentInstantiatedWith = insts }-                      -> insts-                    _ -> [],-                ghcOptPackages           = toNubListR $-                                           Internal.mkGhcOptPackages clbi ,-                ghcOptLinkLibs           = extraLibs libBi,-                ghcOptLinkLibPath        = toNubListR $ extraLibDirs libBi,-                ghcOptLinkFrameworks     = toNubListR $ PD.frameworks libBi,-                ghcOptLinkFrameworkDirs  =-                  toNubListR $ PD.extraFrameworkDirs libBi,-                ghcOptRPaths             = rpaths-              }-          ghcStaticLinkArgs =-              mempty {-                ghcOptStaticLib          = toFlag True,-                ghcOptInputFiles         = toNubListR staticObjectFiles,-                ghcOptOutputFile         = toFlag staticLibFilePath,-                ghcOptExtra              = hcStaticOptions GHC libBi,-                ghcOptHideAllPackages    = toFlag True,-                ghcOptNoAutoLinkPackages = toFlag True,-                ghcOptPackageDBs         = withPackageDB lbi,-                ghcOptThisUnitId = case clbi of-                    LibComponentLocalBuildInfo { componentCompatPackageKey = pk }-                      -> toFlag pk-                    _ -> mempty,-                ghcOptThisComponentId = case clbi of-                    LibComponentLocalBuildInfo-                      { componentInstantiatedWith = insts } ->-                        if null insts-                            then mempty-                            else toFlag (componentComponentId clbi)-                    _ -> mempty,-                ghcOptInstantiatedWith = case clbi of-                    LibComponentLocalBuildInfo-                      { componentInstantiatedWith = insts }-                      -> insts-                    _ -> [],-                ghcOptPackages           = toNubListR $-                                           Internal.mkGhcOptPackages clbi ,-                ghcOptLinkLibs           = extraLibs libBi,-                ghcOptLinkLibPath        = toNubListR $ extraLibDirs libBi-              }--      info verbosity (show (ghcOptPackages ghcSharedLinkArgs))--      whenVanillaLib False $ do-        Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles-        whenGHCiLib $ do-          (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)-          Ld.combineObjectFiles verbosity lbi ldProg-            ghciLibFilePath staticObjectFiles--      whenProfLib $ do-        Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles-        whenGHCiLib $ do-          (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)-          Ld.combineObjectFiles verbosity lbi ldProg-            ghciProfLibFilePath profObjectFiles--      whenSharedLib False $-        runGhcProg ghcSharedLinkArgs--      whenStaticLib False $-        runGhcProg ghcStaticLinkArgs---- | Start a REPL without loading any source files.-startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform-                 -> PackageDBStack -> IO ()-startInterpreter verbosity progdb comp platform packageDBs = do-  let replOpts = mempty {-        ghcOptMode       = toFlag GhcModeInteractive,-        ghcOptPackageDBs = packageDBs-        }-  checkPackageDbStack verbosity comp packageDBs-  (ghcProg, _) <- requireProgram verbosity ghcProgram progdb-  runGHC verbosity ghcProg comp platform replOpts---- -------------------------------------------------------------------------------- Building an executable or foreign library---- | Build a foreign library-buildFLib-  :: Verbosity          -> Cabal.Flag (Maybe Int)-  -> PackageDescription -> LocalBuildInfo-  -> ForeignLib         -> ComponentLocalBuildInfo -> IO ()-buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib--replFLib-  :: [String]                -> Verbosity-  -> Cabal.Flag (Maybe Int)  -> PackageDescription-  -> LocalBuildInfo          -> ForeignLib-  -> ComponentLocalBuildInfo -> IO ()-replFLib replFlags  v njobs pkg lbi =-  gbuild v njobs pkg lbi . GReplFLib replFlags---- | Build an executable with GHC.----buildExe-  :: Verbosity          -> Cabal.Flag (Maybe Int)-  -> PackageDescription -> LocalBuildInfo-  -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe--replExe-  :: [String]                -> Verbosity-  -> Cabal.Flag (Maybe Int)  -> PackageDescription-  -> LocalBuildInfo          -> Executable-  -> ComponentLocalBuildInfo -> IO ()-replExe replFlags v njobs pkg lbi =-  gbuild v njobs pkg lbi . GReplExe replFlags---- | Building an executable, starting the REPL, and building foreign--- libraries are all very similar and implemented in 'gbuild'. The--- 'GBuildMode' distinguishes between the various kinds of operation.-data GBuildMode =-    GBuildExe  Executable-  | GReplExe   [String] Executable-  | GBuildFLib ForeignLib-  | GReplFLib  [String] ForeignLib--gbuildInfo :: GBuildMode -> BuildInfo-gbuildInfo (GBuildExe  exe)  = buildInfo exe-gbuildInfo (GReplExe   _ exe)  = buildInfo exe-gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib-gbuildInfo (GReplFLib  _ flib) = foreignLibBuildInfo flib--gbuildName :: GBuildMode -> String-gbuildName (GBuildExe  exe)  = unUnqualComponentName $ exeName exe-gbuildName (GReplExe   _ exe)  = unUnqualComponentName $ exeName exe-gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib-gbuildName (GReplFLib  _ flib) = unUnqualComponentName $ foreignLibName flib--gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String-gbuildTargetName lbi (GBuildExe  exe)  = exeTargetName (hostPlatform lbi) exe-gbuildTargetName lbi (GReplExe   _ exe)  = exeTargetName (hostPlatform lbi) exe-gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib-gbuildTargetName lbi (GReplFLib  _ flib) = flibTargetName lbi flib--exeTargetName :: Platform -> Executable -> String-exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform---- | Target name for a foreign library (the actual file name)------ We do not use mkLibName and co here because the naming for foreign libraries--- is slightly different (we don't use "_p" or compiler version suffices, and we--- don't want the "lib" prefix on Windows).------ TODO: We do use `dllExtension` and co here, but really that's wrong: they--- use the OS used to build cabal to determine which extension to use, rather--- than the target OS (but this is wrong elsewhere in Cabal as well).-flibTargetName :: LocalBuildInfo -> ForeignLib -> String-flibTargetName lbi flib =-    case (os, foreignLibType flib) of-      (Windows, ForeignLibNativeShared) -> nm <.> "dll"-      (Windows, ForeignLibNativeStatic) -> nm <.> "lib"-      (Linux,   ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt-      (_other,  ForeignLibNativeShared) ->-        "lib" ++ nm <.> dllExtension (hostPlatform lbi)-      (_other,  ForeignLibNativeStatic) ->-        "lib" ++ nm <.> staticLibExtension (hostPlatform lbi)-      (_any,    ForeignLibTypeUnknown)  -> cabalBug "unknown foreign lib type"-  where-    nm :: String-    nm = unUnqualComponentName $ foreignLibName flib--    os :: OS-    os = let (Platform _ os') = hostPlatform lbi-         in os'--    -- If a foreign lib foo has lib-version-info 5:1:2 or-    -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1-    -- Libtool's version-info data is translated into library versions in a-    -- nontrivial way: so refer to libtool documentation.-    versionedExt :: String-    versionedExt =-      let nums = foreignLibVersion flib os-      in foldl (<.>) "so" (map show nums)---- | Name for the library when building.------ If the `lib-version-info` field or the `lib-version-linux` field of--- a foreign library target is set, we need to incorporate that--- version into the SONAME field.------ If a foreign library foo has lib-version-info 5:1:2, it should be--- built as libfoo.so.3.2.1.  We want it to get soname libfoo.so.3.--- However, GHC does not allow overriding soname by setting linker--- options, as it sets a soname of its own (namely the output--- filename), after the user-supplied linker options.  Hence, we have--- to compile the library with the soname as its filename.  We rename--- the compiled binary afterwards.------ This method allows to adjust the name of the library at build time--- such that the correct soname can be set.-flibBuildName :: LocalBuildInfo -> ForeignLib -> String-flibBuildName lbi flib-  -- On linux, if a foreign-library has version data, the first digit is used-  -- to produce the SONAME.-  | (os, foreignLibType flib) ==-    (Linux, ForeignLibNativeShared)-  = let nums = foreignLibVersion flib os-    in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums))-  | otherwise = flibTargetName lbi flib-  where-    os :: OS-    os = let (Platform _ os') = hostPlatform lbi-         in os'--    nm :: String-    nm = unUnqualComponentName $ foreignLibName flib--gbuildIsRepl :: GBuildMode -> Bool-gbuildIsRepl (GBuildExe  _) = False-gbuildIsRepl (GReplExe _ _) = True-gbuildIsRepl (GBuildFLib _) = False-gbuildIsRepl (GReplFLib _ _) = True--gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool-gbuildNeedDynamic lbi bm =-    case bm of-      GBuildExe  _    -> withDynExe lbi-      GReplExe   _ _  -> withDynExe lbi-      GBuildFLib flib -> withDynFLib flib-      GReplFLib  _ flib -> withDynFLib flib-  where-    withDynFLib flib =-      case foreignLibType flib of-        ForeignLibNativeShared ->-          ForeignLibStandalone `notElem` foreignLibOptions flib-        ForeignLibNativeStatic ->-          False-        ForeignLibTypeUnknown  ->-          cabalBug "unknown foreign lib type"--gbuildModDefFiles :: GBuildMode -> [FilePath]-gbuildModDefFiles (GBuildExe _)     = []-gbuildModDefFiles (GReplExe  _ _)     = []-gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib-gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib---- | "Main" module name when overridden by @ghc-options: -main-is ...@--- or 'Nothing' if no @-main-is@ flag could be found.------ In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed.-exeMainModuleName :: Executable -> Maybe ModuleName-exeMainModuleName Executable{buildInfo = bnfo} =-    -- GHC honors the last occurrence of a module name updated via -main-is-    ---    -- Moreover, -main-is when parsed left-to-right can update either-    -- the "Main" module name, or the "main" function name, or both,-    -- see also 'decodeMainIsArg'.-    msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts-  where-    ghcopts = hcOptions GHC bnfo--    findIsMainArgs [] = []-    findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest-    findIsMainArgs (_:rest) = findIsMainArgs rest---- | Decode argument to '-main-is'------ Returns 'Nothing' if argument set only the function name.------ This code has been stolen/refactored from GHC's DynFlags.setMainIs--- function. The logic here is deliberately imperfect as it is--- intended to be bug-compatible with GHC's parser. See discussion in--- https://github.com/haskell/cabal/pull/4539#discussion_r118981753.-decodeMainIsArg :: String -> Maybe ModuleName-decodeMainIsArg arg-  | headOf main_fn isLower-                        -- The arg looked like "Foo.Bar.baz"-  = Just (ModuleName.fromString main_mod)-  | headOf arg isUpper  -- The arg looked like "Foo" or "Foo.Bar"-  = Just (ModuleName.fromString arg)-  | otherwise           -- The arg looked like "baz"-  = Nothing-  where-    headOf :: String -> (Char -> Bool) -> Bool-    headOf str pred' = any pred' (safeHead str)--    (main_mod, main_fn) = splitLongestPrefix arg (== '.')--    splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)-    splitLongestPrefix str pred'-      | null r_pre = (str,           [])-      | otherwise  = (reverse (safeTail r_pre), reverse r_suf)-                           -- 'safeTail' drops the char satisfying 'pred'-      where (r_suf, r_pre) = break pred' (reverse str)---- | A collection of:---    * C input files---    * C++ input files---    * GHC input files---    * GHC input modules------ Used to correctly build and link sources.-data BuildSources = BuildSources {-        cSourcesFiles      :: [FilePath],-        cxxSourceFiles     :: [FilePath],-        inputSourceFiles   :: [FilePath],-        inputSourceModules :: [ModuleName]-    }---- | Locate and return the 'BuildSources' required to build and link.-gbuildSources :: Verbosity-              -> CabalSpecVersion-              -> FilePath-              -> GBuildMode-              -> IO BuildSources-gbuildSources verbosity specVer tmpDir bm =-    case bm of-      GBuildExe  exe  -> exeSources exe-      GReplExe   _ exe  -> exeSources exe-      GBuildFLib flib -> return $ flibSources flib-      GReplFLib  _ flib -> return $ flibSources flib-  where-    exeSources :: Executable -> IO BuildSources-    exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do-      main <- findFileEx verbosity (tmpDir : map getSymbolicPath (hsSourceDirs bnfo)) modPath-      let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe-          otherModNames = exeModules exe--      if isHaskell main-        then-          if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames)-          then do-             -- The cabal manual clearly states that `other-modules` is-             -- intended for non-main modules.  However, there's at least one-             -- important package on Hackage (happy-1.19.5) which-             -- violates this. We workaround this here so that we don't-             -- invoke GHC with e.g.  'ghc --make Main src/Main.hs' which-             -- would result in GHC complaining about duplicate Main-             -- modules.-             ---             -- Finally, we only enable this workaround for-             -- specVersion < 2, as 'cabal-version:>=2.0' cabal files-             -- have no excuse anymore to keep doing it wrong... ;-)-             warn verbosity $ "Enabling workaround for Main module '"-                            ++ prettyShow mainModName-                            ++ "' listed in 'other-modules' illegally!"--             return BuildSources {-                        cSourcesFiles      = cSources bnfo,-                        cxxSourceFiles     = cxxSources bnfo,-                        inputSourceFiles   = [main],-                        inputSourceModules = filter (/= mainModName) $-                                             exeModules exe-                    }--          else return BuildSources {-                          cSourcesFiles      = cSources bnfo,-                          cxxSourceFiles     = cxxSources bnfo,-                          inputSourceFiles   = [main],-                          inputSourceModules = exeModules exe-                      }-        else let (csf, cxxsf)-                   | isCxx main = (       cSources bnfo, main : cxxSources bnfo)-                   -- if main is not a Haskell source-                   -- and main is not a C++ source-                   -- then we assume that it is a C source-                   | otherwise  = (main : cSources bnfo,        cxxSources bnfo)--             in  return BuildSources {-                            cSourcesFiles      = csf,-                            cxxSourceFiles     = cxxsf,-                            inputSourceFiles   = [],-                            inputSourceModules = exeModules exe-                        }--    flibSources :: ForeignLib -> BuildSources-    flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} =-        BuildSources {-            cSourcesFiles      = cSources bnfo,-            cxxSourceFiles     = cxxSources bnfo,-            inputSourceFiles   = [],-            inputSourceModules = foreignLibModules flib-        }--    isHaskell :: FilePath -> Bool-    isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"]--    isCxx :: FilePath -> Bool-    isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"]---- | Generic build function. See comment for 'GBuildMode'.-gbuild :: Verbosity          -> Cabal.Flag (Maybe Int)-       -> PackageDescription -> LocalBuildInfo-       -> GBuildMode         -> ComponentLocalBuildInfo -> IO ()-gbuild verbosity numJobs pkg_descr lbi bm clbi = do-  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)-  let replFlags = case bm of-          GReplExe flags _  -> flags-          GReplFLib flags _ -> flags-          GBuildExe{}       -> mempty-          GBuildFLib{}      -> mempty-      comp       = compiler lbi-      platform   = hostPlatform lbi-      implInfo   = getImplInfo comp-      runGhcProg = runGHC verbosity ghcProg comp platform--  let (bnfo, threaded) = case bm of-        GBuildFLib _ -> popThreadedFlag (gbuildInfo bm)-        _            -> (gbuildInfo bm, False)--  -- the name that GHC really uses (e.g., with .exe on Windows for executables)-  let targetName = gbuildTargetName lbi bm-  let targetDir  = buildDir lbi </> (gbuildName bm)-  let tmpDir     = targetDir    </> (gbuildName bm ++ "-tmp")-  createDirectoryIfMissingVerbose verbosity True targetDir-  createDirectoryIfMissingVerbose verbosity True tmpDir--  -- 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 = exeCoverage lbi-      distPref = fromFlag $ configDistPref $ configFlags lbi-      hpcdir way-        | gbuildIsRepl bm   = mempty  -- HPC is not supported in ghci-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm)-        | otherwise         = mempty--  rpaths <- getRPaths lbi clbi-  buildSources <- gbuildSources verbosity (specVersion pkg_descr) tmpDir bm--  let cSrcs               = cSourcesFiles buildSources-      cxxSrcs             = cxxSourceFiles buildSources-      inputFiles          = inputSourceFiles buildSources-      inputModules        = inputSourceModules buildSources-      isGhcDynamic        = isDynamic comp-      dynamicTooSupported = supportsDynamicToo comp-      cLikeObjs           = map (`replaceExtension` objExtension) cSrcs-      cxxObjs             = map (`replaceExtension` objExtension) cxxSrcs-      needDynamic         = gbuildNeedDynamic lbi bm-      needProfiling       = withProfExe lbi--  -- build executables-      baseOpts   = (componentGhcOptions verbosity lbi bnfo clbi tmpDir)-                    `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeMake,-                      ghcOptInputFiles   = toNubListR inputFiles,-                      ghcOptInputModules = toNubListR inputModules-                    }-      staticOpts = baseOpts `mappend` mempty {-                      ghcOptDynLinkMode    = toFlag GhcStaticOnly,-                      ghcOptHPCDir         = hpcdir Hpc.Vanilla-                   }-      profOpts   = baseOpts `mappend` mempty {-                      ghcOptProfilingMode  = toFlag True,-                      ghcOptProfilingAuto  = Internal.profDetailLevelFlag False-                                             (withProfExeDetail lbi),-                      ghcOptHiSuffix       = toFlag "p_hi",-                      ghcOptObjSuffix      = toFlag "p_o",-                      ghcOptExtra          = hcProfOptions GHC bnfo,-                      ghcOptHPCDir         = hpcdir Hpc.Prof-                    }-      dynOpts    = baseOpts `mappend` mempty {-                      ghcOptDynLinkMode    = toFlag GhcDynamicOnly,-                      -- TODO: Does it hurt to set -fPIC for executables?-                      ghcOptFPic           = toFlag True,-                      ghcOptHiSuffix       = toFlag "dyn_hi",-                      ghcOptObjSuffix      = toFlag "dyn_o",-                      ghcOptExtra          = hcSharedOptions GHC bnfo,-                      ghcOptHPCDir         = hpcdir Hpc.Dyn-                    }-      dynTooOpts = staticOpts `mappend` mempty {-                      ghcOptDynLinkMode    = toFlag GhcStaticAndDynamic,-                      ghcOptDynHiSuffix    = toFlag "dyn_hi",-                      ghcOptDynObjSuffix   = toFlag "dyn_o",-                      ghcOptHPCDir         = hpcdir Hpc.Dyn-                    }-      linkerOpts = mempty {-                      ghcOptLinkOptions       = PD.ldOptions bnfo-                                                ++ [ "-static"-                                                   | withFullyStaticExe lbi ]-                                                -- Pass extra `ld-options` given-                                                -- through to GHC's linker.-                                                ++ maybe [] programOverrideArgs-                                                     (lookupProgram ldProgram (withPrograms lbi)),-                      ghcOptLinkLibs          = extraLibs bnfo,-                      ghcOptLinkLibPath       = toNubListR $ extraLibDirs bnfo,-                      ghcOptLinkFrameworks    = toNubListR $-                                                PD.frameworks bnfo,-                      ghcOptLinkFrameworkDirs = toNubListR $-                                                PD.extraFrameworkDirs bnfo,-                      ghcOptInputFiles     = toNubListR-                                             [tmpDir </> x | x <- cLikeObjs ++ cxxObjs]-                    }-      dynLinkerOpts = mempty {-                      ghcOptRPaths         = rpaths,-                      ghcOptInputFiles     = toNubListR-                                             [tmpDir </> x | x <- cLikeObjs ++ cxxObjs]-                   }-      replOpts   = baseOpts {-                    ghcOptExtra            = Internal.filterGhciFlags-                                             (ghcOptExtra baseOpts)-                                             <> replFlags-                   }-                   -- For a normal compile we do separate invocations of ghc for-                   -- compiling as for linking. But for repl we have to do just-                   -- the one invocation, so that one has to include all the-                   -- linker stuff too, like -l flags and any .o files from C-                   -- files etc.-                   `mappend` linkerOpts-                   `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeInteractive,-                      ghcOptOptimisation = toFlag GhcNoOptimisation-                     }-      commonOpts  | needProfiling = profOpts-                  | needDynamic   = dynOpts-                  | otherwise     = staticOpts-      compileOpts | useDynToo = dynTooOpts-                  | otherwise = commonOpts-      withStaticExe = not needProfiling && not needDynamic--      -- For building exe's that use TH with -prof or -dynamic we actually have-      -- to build twice, once without -prof/-dynamic and then again with-      -- -prof/-dynamic. This is because the code that TH needs to run at-      -- compile time needs to be the vanilla ABI so it can be loaded up and run-      -- by the compiler.-      -- With dynamic-by-default GHC the TH object files loaded at compile-time-      -- need to be .dyn_o instead of .o.-      doingTH = usesTemplateHaskellOrQQ bnfo-      -- Should we use -dynamic-too instead of compiling twice?-      useDynToo = dynamicTooSupported && isGhcDynamic-                  && doingTH && withStaticExe-                  && null (hcSharedOptions GHC bnfo)-      compileTHOpts | isGhcDynamic = dynOpts-                    | otherwise    = staticOpts-      compileForTH-        | gbuildIsRepl bm = False-        | useDynToo       = False-        | isGhcDynamic    = doingTH && (needProfiling || withStaticExe)-        | otherwise       = doingTH && (needProfiling || needDynamic)--   -- Build static/dynamic object files for TH, if needed.-  when compileForTH $-    runGhcProg compileTHOpts { ghcOptNoLink  = toFlag True-                             , ghcOptNumJobs = numJobs }--  -- Do not try to build anything if there are no input files.-  -- This can happen if the cabal file ends up with only cSrcs-  -- but no Haskell modules.-  unless ((null inputFiles && null inputModules)-          || gbuildIsRepl bm) $-    runGhcProg compileOpts { ghcOptNoLink  = toFlag True-                           , ghcOptNumJobs = numJobs }--  -- build any C++ sources-  unless (null cxxSrcs) $ do-   info verbosity "Building C++ Sources..."-   sequence_-     [ do let baseCxxOpts    = Internal.componentCxxGhcOptions verbosity implInfo-                               lbi bnfo clbi tmpDir filename-              vanillaCxxOpts = if isGhcDynamic-                                -- Dynamic GHC requires C++ sources to be built-                                -- with -fPIC for REPL to work. See #2207.-                               then baseCxxOpts { ghcOptFPic = toFlag True }-                               else baseCxxOpts-              profCxxOpts    = vanillaCxxOpts `mappend` mempty {-                                 ghcOptProfilingMode = toFlag True-                               }-              sharedCxxOpts  = vanillaCxxOpts `mappend` mempty {-                                 ghcOptFPic        = toFlag True,-                                 ghcOptDynLinkMode = toFlag GhcDynamicOnly-                               }-              opts | needProfiling = profCxxOpts-                   | needDynamic   = sharedCxxOpts-                   | otherwise     = vanillaCxxOpts-              -- TODO: Placing all Haskell, C, & C++ objects in a single directory-              --       Has the potential for file collisions. In general we would-              --       consider this a user error. However, we should strive to-              --       add a warning if this occurs.-              odir = fromFlag (ghcOptObjDir opts)-          createDirectoryIfMissingVerbose verbosity True odir-          needsRecomp <- checkNeedsRecompilation filename opts-          when needsRecomp $-            runGhcProg opts-     | filename <- cxxSrcs ]--  -- build any C sources-  unless (null cSrcs) $ do-   info verbosity "Building C Sources..."-   sequence_-     [ do let baseCcOpts    = Internal.componentCcGhcOptions verbosity implInfo-                              lbi bnfo clbi tmpDir filename-              vanillaCcOpts = if isGhcDynamic-                              -- Dynamic GHC requires C sources to be built-                              -- with -fPIC for REPL to work. See #2207.-                              then baseCcOpts { ghcOptFPic = toFlag True }-                              else baseCcOpts-              profCcOpts    = vanillaCcOpts `mappend` mempty {-                                ghcOptProfilingMode = toFlag True-                              }-              sharedCcOpts  = vanillaCcOpts `mappend` mempty {-                                ghcOptFPic        = toFlag True,-                                ghcOptDynLinkMode = toFlag GhcDynamicOnly-                              }-              opts | needProfiling = profCcOpts-                   | needDynamic   = sharedCcOpts-                   | otherwise     = vanillaCcOpts-              odir = fromFlag (ghcOptObjDir opts)-          createDirectoryIfMissingVerbose verbosity True odir-          needsRecomp <- checkNeedsRecompilation filename opts-          when needsRecomp $-            runGhcProg opts-     | filename <- cSrcs ]--  -- TODO: problem here is we need the .c files built first, so we can load them-  -- with ghci, but .c files can depend on .h files generated by ghc by ffi-  -- exports.-  case bm of-    GReplExe  _ _ -> runGhcProg replOpts-    GReplFLib _ _ -> runGhcProg replOpts-    GBuildExe _ -> do-      let linkOpts = commonOpts-                   `mappend` linkerOpts-                   `mappend` mempty {-                      ghcOptLinkNoHsMain = toFlag (null inputFiles)-                     }-                   `mappend` (if withDynExe lbi then dynLinkerOpts else mempty)--      info verbosity "Linking..."-      -- Work around old GHCs not relinking in this-      -- situation, see #3294-      let target = targetDir </> targetName-      when (compilerVersion comp < mkVersion [7,7]) $ do-        e <- doesFileExist target-        when e (removeFile target)-      runGhcProg linkOpts { ghcOptOutputFile = toFlag target }-    GBuildFLib flib -> do-      let rtsInfo  = extractRtsInfo lbi-          rtsOptLinkLibs = [-              if needDynamic-                  then if threaded-                            then dynRtsThreadedLib (rtsDynamicInfo rtsInfo)-                            else dynRtsVanillaLib (rtsDynamicInfo rtsInfo)-                  else if threaded-                           then statRtsThreadedLib (rtsStaticInfo rtsInfo)-                           else statRtsVanillaLib (rtsStaticInfo rtsInfo)-              ]-          linkOpts = case foreignLibType flib of-            ForeignLibNativeShared ->-                        commonOpts-              `mappend` linkerOpts-              `mappend` dynLinkerOpts-              `mappend` mempty {-                 ghcOptLinkNoHsMain    = toFlag True,-                 ghcOptShared          = toFlag True,-                 ghcOptLinkLibs        = rtsOptLinkLibs,-                 ghcOptLinkLibPath     = toNubListR $ rtsLibPaths rtsInfo,-                 ghcOptFPic            = toFlag True,-                 ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm-                }-              -- See Note [RPATH]-              `mappend` ifNeedsRPathWorkaround lbi mempty {-                  ghcOptLinkOptions = ["-Wl,--no-as-needed"]-                , ghcOptLinkLibs    = ["ffi"]-                }-            ForeignLibNativeStatic ->-              -- this should be caught by buildFLib-              -- (and if we do implement this, we probably don't even want to call-              -- ghc here, but rather Ar.createArLibArchive or something)-              cabalBug "static libraries not yet implemented"-            ForeignLibTypeUnknown ->-              cabalBug "unknown foreign lib type"-      -- We build under a (potentially) different filename to set a-      -- soname on supported platforms.  See also the note for-      -- @flibBuildName@.-      info verbosity "Linking..."-      let buildName = flibBuildName lbi flib-      runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> buildName) }-      renameFile (targetDir </> buildName) (targetDir </> targetName)--{--Note [RPATH]-~~~~~~~~~~~~--Suppose that the dynamic library depends on `base`, but not (directly) on-`integer-gmp` (which, however, is a dependency of `base`). We will link the-library as--    gcc ... -lHSbase-4.7.0.2-ghc7.8.4 -lHSinteger-gmp-0.5.1.0-ghc7.8.4 ...--However, on systems (like Ubuntu) where the linker gets called with `-as-needed`-by default, the linker will notice that `integer-gmp` isn't actually a direct-dependency and hence omit the link.--Then when we attempt to link a C program against this dynamic library, the-_static_ linker will attempt to verify that all symbols can be resolved.  The-dynamic library itself does not require any symbols from `integer-gmp`, but-`base` does. In order to verify that the symbols used by `base` can be-resolved, the static linker needs to be able to _find_ integer-gmp.--Finding the `base` dependency is simple, because the dynamic elf header-(`readelf -d`) for the library that we have created looks something like--    (NEEDED) Shared library: [libHSbase-4.7.0.2-ghc7.8.4.so]-    (RPATH)  Library rpath: [/path/to/base-4.7.0.2:...]--However, when it comes to resolving the dependency on `integer-gmp`, it needs-to look at the dynamic header for `base`. On modern ghc (7.8 and higher) this-looks something like--    (NEEDED) Shared library: [libHSinteger-gmp-0.5.1.0-ghc7.8.4.so]-    (RPATH)  Library rpath: [$ORIGIN/../integer-gmp-0.5.1.0:...]--This specifies the location of `integer-gmp` _in terms of_ the location of base-(using the `$ORIGIN`) variable. But here's the crux: when the static linker-attempts to verify that all symbols can be resolved, [**IT DOES NOT RESOLVE-`$ORIGIN`**](http://stackoverflow.com/questions/6323603/ld-using-rpath-origin-inside-a-shared-library-recursive).-As a consequence, it will not be able to resolve the symbols and report the-missing symbols as errors, _even though the dynamic linker **would** be able to-resolve these symbols_. We can tell the static linker not to report these-errors by using `--unresolved-symbols=ignore-all` and all will be fine when we-run the program ([(indeed, this is what the gold linker-does)](https://sourceware.org/ml/binutils/2013-05/msg00038.html), but it makes-the resulting library more difficult to use.--Instead what we can do is make sure that the generated dynamic library has-explicit top-level dependencies on these libraries. This means that the static-linker knows where to find them, and when we have transitive dependencies on-the same libraries the linker will only load them once, so we avoid needing to-look at the `RPATH` of our dependencies. We can do this by passing-`--no-as-needed` to the linker, so that it doesn't omit any libraries.--Note that on older ghc (7.6 and before) the Haskell libraries don't have an-RPATH set at all, which makes it even more important that we make these-top-level dependencies.--Finally, we have to explicitly link against `libffi` for the same reason. For-newer ghc this _happens_ to be unnecessary on many systems because `libffi` is-a library which is not specific to GHC, and when the static linker verifies-that all symbols can be resolved it will find the `libffi` that is globally-installed (completely independent from ghc). Of course, this may well be the-_wrong_ version of `libffi`, but it's quite possible that symbol resolution-happens to work. This is of course the wrong approach, which is why we link-explicitly against `libffi` so that we will find the _right_ version of-`libffi`.--}---- | Do we need the RPATH workaround?------ See Note [RPATH].-ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a-ifNeedsRPathWorkaround lbi a =-  case hostPlatform lbi of-    Platform _ Linux -> a-    _otherwise       -> mempty--data DynamicRtsInfo = DynamicRtsInfo {-    dynRtsVanillaLib          :: FilePath-  , dynRtsThreadedLib         :: FilePath-  , dynRtsDebugLib            :: FilePath-  , dynRtsEventlogLib         :: FilePath-  , dynRtsThreadedDebugLib    :: FilePath-  , dynRtsThreadedEventlogLib :: FilePath-  }--data StaticRtsInfo = StaticRtsInfo {-    statRtsVanillaLib           :: FilePath-  , statRtsThreadedLib          :: FilePath-  , statRtsDebugLib             :: FilePath-  , statRtsEventlogLib          :: FilePath-  , statRtsThreadedDebugLib     :: FilePath-  , statRtsThreadedEventlogLib  :: FilePath-  , statRtsProfilingLib         :: FilePath-  , statRtsThreadedProfilingLib :: FilePath-  }--data RtsInfo = RtsInfo {-    rtsDynamicInfo :: DynamicRtsInfo-  , rtsStaticInfo  :: StaticRtsInfo-  , rtsLibPaths    :: [FilePath]-  }---- | Extract (and compute) information about the RTS library------ TODO: This hardcodes the name as @HSrts-ghc<version>@. I don't know if we can--- find this information somewhere. We can lookup the 'hsLibraries' field of--- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which--- doesn't really help.-extractRtsInfo :: LocalBuildInfo -> RtsInfo-extractRtsInfo lbi =-    case PackageIndex.lookupPackageName-         (installedPkgs lbi) (mkPackageName "rts") of-      [(_, [rts])] -> aux rts-      _otherwise   -> error "No (or multiple) ghc rts package is registered"-  where-    aux :: InstalledPackageInfo -> RtsInfo-    aux rts = RtsInfo {-        rtsDynamicInfo = DynamicRtsInfo {-            dynRtsVanillaLib          = withGhcVersion "HSrts"-          , dynRtsThreadedLib         = withGhcVersion "HSrts_thr"-          , dynRtsDebugLib            = withGhcVersion "HSrts_debug"-          , dynRtsEventlogLib         = withGhcVersion "HSrts_l"-          , dynRtsThreadedDebugLib    = withGhcVersion "HSrts_thr_debug"-          , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l"-          }-      , rtsStaticInfo = StaticRtsInfo {-            statRtsVanillaLib           = "HSrts"-          , statRtsThreadedLib          = "HSrts_thr"-          , statRtsDebugLib             = "HSrts_debug"-          , statRtsEventlogLib          = "HSrts_l"-          , statRtsThreadedDebugLib     = "HSrts_thr_debug"-          , statRtsThreadedEventlogLib  = "HSrts_thr_l"-          , statRtsProfilingLib         = "HSrts_p"-          , statRtsThreadedProfilingLib = "HSrts_thr_p"-          }-      , rtsLibPaths   = InstalledPackageInfo.libraryDirs rts-      }-    withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi))))---- | Returns True if the modification date of the given source file is newer than--- the object file we last compiled for it, or if no object file exists yet.-checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool-checkNeedsRecompilation filename opts = filename `moreRecentFile` oname-    where oname = getObjectFileName filename opts---- | Finds the object file name of the given source file-getObjectFileName :: FilePath -> GhcOptions -> FilePath-getObjectFileName filename opts = oname-    where odir  = fromFlag (ghcOptObjDir opts)-          oext  = fromFlagOrDefault "o" (ghcOptObjSuffix opts)-          oname = odir </> replaceExtension filename oext---- | Calculate the RPATHs for the component we are building.------ Calculates relative RPATHs when 'relocatable' is set.-getRPaths :: LocalBuildInfo-          -> ComponentLocalBuildInfo -- ^ Component we are building-          -> IO (NubListR FilePath)-getRPaths lbi clbi | supportRPaths hostOS = do-    libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi-    let hostPref = case hostOS of-                     OSX -> "@loader_path"-                     _   -> "$ORIGIN"-        relPath p = if isRelative p then hostPref </> p else p-        rpaths    = toNubListR (map relPath libraryPaths)-    return rpaths-  where-    (Platform _ hostOS) = hostPlatform lbi-    compid              = compilerId . compiler $ lbi--    -- The list of RPath-supported operating systems below reflects the-    -- platforms on which Cabal's RPATH handling is tested. It does _NOT_-    -- reflect whether the OS supports RPATH.--    -- E.g. when this comment was written, the *BSD operating systems were-    -- untested with regards to Cabal RPATH handling, and were hence set to-    -- 'False', while those operating systems themselves do support RPATH.-    supportRPaths Linux       = True-    supportRPaths Windows     = False-    supportRPaths OSX         = True-    supportRPaths FreeBSD     =-      case compid of-        CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True-        _                                              -> False-    supportRPaths OpenBSD     = False-    supportRPaths NetBSD      = False-    supportRPaths DragonFly   = False-    supportRPaths Solaris     = False-    supportRPaths AIX         = False-    supportRPaths HPUX        = False-    supportRPaths IRIX        = False-    supportRPaths HaLVM       = False-    supportRPaths IOS         = False-    supportRPaths Android     = False-    supportRPaths Ghcjs       = False-    supportRPaths Hurd        = False-    supportRPaths (OtherOS _) = False-    -- Do _not_ add a default case so that we get a warning here when a new OS-    -- is added.--getRPaths _ _ = return mempty---- | Remove the "-threaded" flag when building a foreign library, as it has no---   effect when used with "-shared". Returns the updated 'BuildInfo', along---   with whether or not the flag was present, so we can use it to link against---   the appropriate RTS on our own.-popThreadedFlag :: BuildInfo -> (BuildInfo, Bool)-popThreadedFlag bi =-  ( bi { options = filterHcOptions (/= "-threaded") (options bi) }-  , hasThreaded (options bi))--  where-    filterHcOptions :: (String -> Bool)-                    -> PerCompilerFlavor [String]-                    -> PerCompilerFlavor [String]-    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 :: Verbosity -> PackageDescription -> LocalBuildInfo-           -> Library -> ComponentLocalBuildInfo -> IO String-libAbiHash verbosity _pkg_descr lbi lib clbi = do-  let-      libBi = libBuildInfo lib-      comp        = compiler lbi-      platform    = hostPlatform lbi-      vanillaArgs0 =-        (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi))-        `mappend` mempty {-          ghcOptMode         = toFlag GhcModeAbiHash,-          ghcOptInputModules = toNubListR $ exposedModules lib-        }-      vanillaArgs =-          -- Package DBs unnecessary, and break ghc-cabal. See #3633-          -- BUT, put at least the global database so that 7.4 doesn't-          -- break.-          vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB]-                       , ghcOptPackages = mempty }-      sharedArgs = vanillaArgs `mappend` mempty {-                       ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                       ghcOptFPic        = toFlag True,-                       ghcOptHiSuffix    = toFlag "dyn_hi",-                       ghcOptObjSuffix   = toFlag "dyn_o",-                       ghcOptExtra       = hcSharedOptions GHC libBi-                   }-      profArgs   = vanillaArgs `mappend` mempty {-                     ghcOptProfilingMode = toFlag True,-                     ghcOptProfilingAuto = Internal.profDetailLevelFlag True-                                             (withProfLibDetail lbi),-                     ghcOptHiSuffix      = toFlag "p_hi",-                     ghcOptObjSuffix     = toFlag "p_o",-                     ghcOptExtra         = hcProfOptions GHC libBi-                   }-      ghcArgs-        | withVanillaLib lbi = vanillaArgs-        | withSharedLib lbi = sharedArgs-        | withProfLib lbi = profArgs-        | otherwise = error "libAbiHash: Can't find an enabled library way"--  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)-  hash <- getProgramInvocationOutput verbosity-          (ghcInvocation ghcProg comp platform ghcArgs)-  return (takeWhile (not . isSpace) hash)--componentGhcOptions :: Verbosity -> LocalBuildInfo-                    -> BuildInfo -> ComponentLocalBuildInfo -> FilePath-                    -> GhcOptions-componentGhcOptions verbosity lbi =-  Internal.componentGhcOptions verbosity implInfo lbi-  where-    comp     = compiler lbi-    implInfo = getImplInfo comp--componentCcGhcOptions :: Verbosity -> LocalBuildInfo-                      -> BuildInfo -> ComponentLocalBuildInfo-                      -> FilePath -> FilePath-                      -> GhcOptions-componentCcGhcOptions verbosity lbi =-    Internal.componentCcGhcOptions verbosity implInfo lbi-  where-    comp     = compiler lbi-    implInfo = getImplInfo comp---- -------------------------------------------------------------------------------- Installing---- |Install executables for GHC.-installExe :: Verbosity-           -> LocalBuildInfo-           -> FilePath -- ^Where to copy the files to-           -> FilePath  -- ^Build location-           -> (FilePath, FilePath)  -- ^Executable (prefix,suffix)-           -> PackageDescription-           -> Executable-           -> IO ()-installExe verbosity lbi binDir buildPref-  (progprefix, progsuffix) _pkg exe = do-  createDirectoryIfMissingVerbose verbosity True binDir-  let exeName' = unUnqualComponentName $ exeName exe-      exeFileName = exeTargetName (hostPlatform lbi) exe-      fixedExeBaseName = progprefix ++ exeName' ++ progsuffix-      installBinary dest = do-          installExecutableFile verbosity-            (buildPref </> exeName' </> exeFileName)-            (dest <.> exeExtension (hostPlatform lbi))-          when (stripExes lbi) $-            Strip.stripExe verbosity (hostPlatform lbi) (withPrograms lbi)-                           (dest <.> exeExtension (hostPlatform lbi))-  installBinary (binDir </> fixedExeBaseName)---- |Install foreign library for GHC.-installFLib :: Verbosity-            -> LocalBuildInfo-            -> FilePath  -- ^install location-            -> FilePath  -- ^Build location-            -> PackageDescription-            -> ForeignLib-            -> IO ()-installFLib verbosity lbi targetDir builtDir _pkg flib =-    install (foreignLibIsShared flib)-            builtDir-            targetDir-            (flibTargetName lbi flib)-  where-    install isShared srcDir dstDir name = do-      let src = srcDir </> name-          dst = dstDir </> name-      createDirectoryIfMissingVerbose verbosity True targetDir-      -- TODO: Should we strip? (stripLibs lbi)-      if isShared-        then installExecutableFile verbosity src dst-        else installOrdinaryFile   verbosity src dst-      -- Now install appropriate symlinks if library is versioned-      let (Platform _ os) = hostPlatform lbi-      when (not (null (foreignLibVersion flib os))) $ do-          when (os /= Linux) $ die' verbosity-            -- It should be impossible to get here.-            "Can't install foreign-library symlink on non-Linux OS"-#ifndef mingw32_HOST_OS-          -- 'createSymbolicLink file1 file2' creates a symbolic link-          -- named 'file2' which points to the file 'file1'.-          -- Note that we do want a symlink to 'name' rather than-          -- 'dst', because the symlink will be relative to the-          -- directory it's created in.-          -- Finally, we first create the symlinks in a temporary-          -- directory and then rename to simulate 'ln --force'.-          withTempDirectory verbosity dstDir nm $ \tmpDir -> do-              let link1 = flibBuildName lbi flib-                  link2 = "lib" ++ nm <.> "so"-              createSymbolicLink name (tmpDir </> link1)-              renameFile (tmpDir </> link1) (dstDir </> link1)-              createSymbolicLink name (tmpDir </> link2)-              renameFile (tmpDir </> link2) (dstDir </> link2)-        where-          nm :: String-          nm = unUnqualComponentName $ foreignLibName flib-#endif /* mingw32_HOST_OS */----- |Install for ghc, .hi, .a and, if --with-ghci given, .o-installLib    :: Verbosity-              -> LocalBuildInfo-              -> FilePath  -- ^install location-              -> FilePath  -- ^install location for dynamic libraries-              -> FilePath  -- ^Build location-              -> PackageDescription-              -> Library-              -> ComponentLocalBuildInfo-              -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do-  -- copy .hi files over:-  whenVanilla $ copyModuleFiles "hi"-  whenProf    $ copyModuleFiles "p_hi"-  whenShared  $ copyModuleFiles "dyn_hi"--  -- copy the built library files over:-  whenHasCode $ do-    whenVanilla $ do-      sequence_ [ installOrdinary-                    builtDir-                    targetDir-                    (mkGenericStaticLibName (l ++ f))-                | l <- getHSLibraryName-                       (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib))-                , f <- "":extraLibFlavours (libBuildInfo lib)-                ]-      whenGHCi $ installOrdinary builtDir targetDir ghciLibName-    whenProf $ do-      installOrdinary builtDir targetDir profileLibName-      whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName-    whenShared $ if-      -- The behavior for "extra-bundled-libraries" changed in version 2.5.0.-      -- See ghc issue #15837 and Cabal PR #5855.-      | specVersion pkg < CabalSpecV3_0 -> do-        sequence_ [ installShared builtDir dynlibTargetDir-              (mkGenericSharedLibName platform compiler_id (l ++ f))-          | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib)-          , f <- "":extraDynLibFlavours (libBuildInfo lib)-          ]-      | otherwise -> do-        sequence_ [ installShared-                        builtDir-                        dynlibTargetDir-                        (mkGenericSharedLibName-                          platform-                          compiler_id-                          (getHSLibraryName uid ++ f))-                  | f <- "":extraDynLibFlavours (libBuildInfo lib)-                  ]-        sequence_ [ do-                    files <- getDirectoryContents builtDir-                    let l' = mkGenericSharedBundledLibName-                              platform-                              compiler_id-                              l-                    forM_ files $ \ file ->-                      when (l' `isPrefixOf` file) $ do-                        isFile <- doesFileExist (builtDir </> file)-                        when isFile $ do-                          installShared-                            builtDir-                            dynlibTargetDir-                            file-                  | l <- extraBundledLibs (libBuildInfo lib)-                  ]--  where-    builtDir = componentBuildDir lbi clbi--    install isShared srcDir dstDir name = do-      let src = srcDir </> name-          dst = dstDir </> name--      createDirectoryIfMissingVerbose verbosity True dstDir--      if isShared-        then installExecutableFile verbosity src dst-        else installOrdinaryFile   verbosity src dst--      when (stripLibs lbi) $ Strip.stripLib verbosity-                             platform (withPrograms lbi) dst--    installOrdinary = install False-    installShared   = install True--    copyModuleFiles ext =-      findModuleFilesEx verbosity [builtDir] [ext] (allLibModules lib clbi)-      >>= installOrdinaryFiles verbosity targetDir--    compiler_id = compilerId (compiler lbi)-    platform = hostPlatform lbi-    uid = componentUnitId clbi-    profileLibName = mkProfLibName          uid-    ghciLibName    = Internal.mkGHCiLibName uid-    ghciProfLibName = Internal.mkGHCiProfLibName uid--    hasLib    = not $ null (allLibModules lib clbi)-                   && null (cSources (libBuildInfo lib))-                   && null (cxxSources (libBuildInfo lib))-                   && null (cmmSources (libBuildInfo lib))-                   && null (asmSources (libBuildInfo lib))-    has_code = not (componentIsIndefinite clbi)-    whenHasCode = when has_code-    whenVanilla = when (hasLib && withVanillaLib lbi)-    whenProf    = when (hasLib && withProfLib    lbi && has_code)-    whenGHCi    = when (hasLib && withGHCiLib    lbi && has_code)-    whenShared  = when (hasLib && withSharedLib  lbi && has_code)---- -------------------------------------------------------------------------------- Registering--hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo-hcPkgInfo progdb = HcPkg.HcPkgInfo-  { HcPkg.hcPkgProgram         = ghcPkgProg-  , HcPkg.noPkgDbStack         = v < [6,9]-  , HcPkg.noVerboseFlag        = v < [6,11]-  , HcPkg.flagPackageConf      = v < [7,5]-  , HcPkg.supportsDirDbs       = v >= [6,8]-  , HcPkg.requiresDirDbs       = v >= [7,10]-  , HcPkg.nativeMultiInstance  = v >= [7,10]-  , HcPkg.recacheMultiInstance = v >= [6,12]-  , HcPkg.suppressFilesCheck   = v >= [6,6]-  }-  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--registerPackage-  :: Verbosity-  -> ProgramDb-  -> PackageDBStack-  -> InstalledPackageInfo-  -> HcPkg.RegisterOptions-  -> IO ()-registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions =-    HcPkg.register (hcPkgInfo progdb) verbosity packageDbs-                   installedPkgInfo registerOptions--pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath-pkgRoot verbosity lbi = pkgRoot'-   where-    pkgRoot' GlobalPackageDB =-      let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi)-      in  fmap takeDirectory (getGlobalPackageDB verbosity ghcProg)-    pkgRoot' UserPackageDB = do-      appDir <- getGhcAppDir-      let ver      = compilerVersion (compiler lbi)-          subdir   = System.Info.arch ++ '-':System.Info.os-                     ++ '-':prettyShow ver-          rootDir  = appDir </> subdir-      -- We must create the root directory for the user package database if it-      -- does not yet exists. Otherwise '${pkgroot}' will resolve to a-      -- directory at the time of 'ghc-pkg register', and registration will-      -- fail.-      createDirectoryIfMissing True rootDir-      return rootDir-    pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp)---- -------------------------------------------------------------------------------- Utils--isDynamic :: Compiler -> Bool-isDynamic = Internal.ghcLookupProperty "GHC Dynamic"--supportsDynamicToo :: Compiler -> Bool-supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"--withExt :: FilePath -> String -> FilePath-withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else ""+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.GHC+-- Copyright   :  Isaac Jones 2003-2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This is a fairly large module. It contains most of the GHC-specific code for+-- configuring, building and installing packages. It also exports a function+-- for finding out what packages are already installed. Configuring involves+-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions+-- this version of ghc supports and returning a 'Compiler' value.+--+-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out+-- what packages are installed.+--+-- Building is somewhat complex as there is quite a bit of information to take+-- into account. We have to build libs and programs, possibly for profiling and+-- shared libs. We have to support building libraries that will be usable by+-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files+-- using ghc. Linking, especially for @split-objs@ is remarkably complex,+-- partly because there tend to be 1,000's of @.o@ files and this can often be+-- more than we can pass to the @ld@ or @ar@ programs in one go.+--+-- Installing for libs and exes involves finding the right files and copying+-- them to the right places. One of the more tricky things about this module is+-- remembering the layout of files in the build directory (which is not+-- explicitly documented) and thus what search dirs are used for various kinds+-- of files.+module Distribution.Simple.GHC+  ( getGhcInfo+  , configure+  , configureCompiler+  , compilerProgramDb+  , getInstalledPackages+  , getInstalledPackagesMonitorFiles+  , getPackageDBContents+  , buildLib+  , buildFLib+  , buildExe+  , replLib+  , replFLib+  , replExe+  , startInterpreter+  , installLib+  , installFLib+  , installExe+  , libAbiHash+  , hcPkgInfo+  , registerPackage+  , Internal.componentGhcOptions+  , Internal.componentCcGhcOptions+  , getGhcAppDir+  , getLibDir+  , compilerBuildWay+  , getGlobalPackageDB+  , pkgRoot++    -- * Constructing and deconstructing GHC environment files+  , Internal.GhcEnvironmentFileEntry (..)+  , Internal.simpleGhcEnvironmentFile+  , Internal.renderGhcEnvironmentFile+  , Internal.writeGhcEnvironmentFile+  , Internal.ghcPlatformAndVersionString+  , readGhcEnvironmentFile+  , parseGhcEnvironmentFile+  , ParseErrorExc (..)++    -- * Version-specific implementation quirks+  , getImplInfo+  , GhcImplInfo (..)+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Control.Arrow ((***))+import Control.Monad (forM_)+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+import Distribution.Simple.Build.Inputs (PreBuildComponentInputs (..))+import Distribution.Simple.BuildPaths+import Distribution.Simple.Compiler+import Distribution.Simple.Errors+import qualified Distribution.Simple.GHC.Build as GHC+import Distribution.Simple.GHC.Build.Modules (BuildWay (..))+import Distribution.Simple.GHC.Build.Utils+import Distribution.Simple.GHC.EnvironmentParser+import Distribution.Simple.GHC.ImplInfo+import qualified Distribution.Simple.GHC.Internal as Internal+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PreProcess.Types+import Distribution.Simple.Program+import Distribution.Simple.Program.Builtin (runghcProgram)+import Distribution.Simple.Program.GHC+import qualified Distribution.Simple.Program.HcPkg as HcPkg+import qualified Distribution.Simple.Program.Strip as Strip+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Repl+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.ParStrat+import Distribution.Types.TargetInfo+import Distribution.Utils.NubList+import Distribution.Utils.Path+import Distribution.Verbosity+import Distribution.Version+import Language.Haskell.Extension+import System.FilePath+  ( isRelative+  , takeDirectory+  )+import qualified System.Info+#ifndef mingw32_HOST_OS+import System.Posix (createSymbolicLink)+#endif /* mingw32_HOST_OS */++{- FOURMOLU_DISABLE -}+import System.Directory+  ( canonicalizePath+  , createDirectoryIfMissing+  , doesDirectoryExist+  , doesFileExist+  , getAppUserDataDirectory+  , getDirectoryContents+#ifndef mingw32_HOST_OS+  , renameFile+#endif+  )+{- FOURMOLU_ENABLE -}++import Distribution.Simple.Setup (BuildingWhat (..))+import Distribution.Simple.Setup.Build++-- -----------------------------------------------------------------------------+-- 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)++  -- Cabal currently supports GHC less than `maxGhcVersion`+  let maxGhcVersion = mkVersion [9, 16]+  unless (ghcVersion < maxGhcVersion) $+    warn verbosity $+      "Unknown/unsupported 'ghc' version detected "+        ++ "(Cabal "+        ++ prettyShow cabalVersion+        ++ " supports 'ghc' version < "+        ++ prettyShow maxGhcVersion+        ++ "): "+        ++ programPath ghcProg+        ++ " is version "+        ++ prettyShow ghcVersion++  let implInfo = ghcVersionImplInfo ghcVersion+  languages <- Internal.getLanguages verbosity implInfo ghcProg+  extensions0 <- Internal.getExtensions verbosity implInfo 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++      -- starting with GHC 8.0, `TemplateHaskell` will be omitted from+      -- `--supported-extensions` when it's not available.+      -- for older GHCs we can use the "Have interpreter" property to+      -- filter out `TemplateHaskell`+      filterExtTH+        | ghcVersion < mkVersion [8]+        , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap =+            filterExt TemplateHaskell+        | otherwise = id++      filterExt ext = filter ((/= EnableExtension ext) . fst)++      compilerId :: CompilerId+      compilerId = CompilerId GHC ghcVersion++      -- 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".+      compilerAbiTag :: AbiTag+      compilerAbiTag =+        maybe+          NoAbiTag+          AbiTag+          ( dropWhile (== '-') . stripCommonPrefix (prettyShow compilerId)+              <$> Map.lookup "Project Unit Id" ghcInfoMap+          )++  let comp =+        Compiler+          { compilerId+          , compilerAbiTag+          , compilerCompat = []+          , compilerLanguages = languages+          , compilerExtensions = extensions+          , compilerProperties = ghcInfoMap+          }+      compPlatform = Internal.targetPlatform ghcInfo+  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+  let+    ghcProg = fromJust $ lookupProgram ghcProgram progdb1+    ghcVersion = compilerVersion comp++  -- 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++      -- configure gcc, ld, ar etc... based on the paths stored+      -- in the GHC settings file+      progdb4 =+        Internal.configureToolchain+          (ghcVersionImplInfo ghcVersion)+          ghcProg+          (compilerProperties comp)+          progdb3+  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:+--+-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe)+-- > /usr/local/bin/ghc-pkg-6.6.1(.exe)+-- > /usr/local/bin/ghc-pkg(.exe)+guessToolFromGhcPath+  :: Program+  -> ConfiguredProgram+  -> Verbosity+  -> ProgramSearchPath+  -> IO (Maybe (FilePath, [FilePath]))+guessToolFromGhcPath tool ghcProg verbosity searchpath =+  do+    let toolname = programName tool+        given_path = programPath ghcProg+        given_dir = takeDirectory given_path+    real_path <- canonicalizePath given_path+    let real_dir = takeDirectory real_path+        versionSuffix path = takeVersionSuffix (dropExeExtension path)+        given_suf = versionSuffix given_path+        real_suf = versionSuffix real_path+        guessNormal dir = dir </> toolname <.> exeExtension buildPlatform+        guessGhcVersioned dir suf =+          dir+            </> (toolname ++ "-ghc" ++ suf)+              <.> exeExtension buildPlatform+        guessVersioned dir suf =+          dir+            </> (toolname ++ suf)+              <.> exeExtension buildPlatform+        mkGuesses dir suf+          | null suf = [guessNormal dir]+          | otherwise =+              [ guessGhcVersioned dir suf+              , guessVersioned dir suf+              , guessNormal dir+              ]+        -- order matters here, see https://github.com/haskell/cabal/issues/7390+        guesses =+          ( if real_path == given_path+              then []+              else mkGuesses real_dir real_suf+          )+            ++ mkGuesses given_dir given_suf+    info verbosity $+      "looking for tool "+        ++ toolname+        ++ " near compiler in "+        ++ given_dir+    debug verbosity $ "candidate locations: " ++ show guesses+    exists <- traverse doesFileExist guesses+    case [file | (file, True) <- zip guesses exists] of+      -- If we can't find it near ghc, fall back to the usual+      -- method.+      [] -> programFindLocation tool verbosity searchpath+      (fp : _) -> do+        info verbosity $ "found " ++ toolname ++ " in " ++ fp+        let lookedAt =+              map fst+                . takeWhile (\(_file, exist) -> not exist)+                $ zip guesses exists+        return (Just (fp, lookedAt))+  where+    takeVersionSuffix :: FilePath -> String+    takeVersionSuffix = takeWhileEndLE isSuffixChar++    isSuffixChar :: Char -> Bool+    isSuffixChar c = isDigit c || c == '.' || c == '-'++-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a+-- corresponding ghc-pkg, we try looking for both a versioned and unversioned+-- ghc-pkg in the same dir, that is:+--+-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe)+-- > /usr/local/bin/ghc-pkg-6.6.1(.exe)+-- > /usr/local/bin/ghc-pkg(.exe)+guessGhcPkgFromGhcPath+  :: ConfiguredProgram+  -> Verbosity+  -> ProgramSearchPath+  -> IO (Maybe (FilePath, [FilePath]))+guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram++-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a+-- corresponding hsc2hs, we try looking for both a versioned and unversioned+-- hsc2hs in the same dir, that is:+--+-- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe)+-- > /usr/local/bin/hsc2hs-6.6.1(.exe)+-- > /usr/local/bin/hsc2hs(.exe)+guessHsc2hsFromGhcPath+  :: ConfiguredProgram+  -> Verbosity+  -> ProgramSearchPath+  -> IO (Maybe (FilePath, [FilePath]))+guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram++-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a+-- corresponding haddock, we try looking for both a versioned and unversioned+-- haddock in the same dir, that is:+--+-- > /usr/local/bin/haddock-ghc-6.6.1(.exe)+-- > /usr/local/bin/haddock-6.6.1(.exe)+-- > /usr/local/bin/haddock(.exe)+guessHaddockFromGhcPath+  :: ConfiguredProgram+  -> Verbosity+  -> ProgramSearchPath+  -> IO (Maybe (FilePath, [FilePath]))+guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram++guessHpcFromGhcPath+  :: ConfiguredProgram+  -> Verbosity+  -> ProgramSearchPath+  -> IO (Maybe (FilePath, [FilePath]))+guessHpcFromGhcPath = guessToolFromGhcPath hpcProgram++guessRunghcFromGhcPath+  :: ConfiguredProgram+  -> Verbosity+  -> ProgramSearchPath+  -> IO (Maybe (FilePath, [FilePath]))+guessRunghcFromGhcPath = guessToolFromGhcPath runghcProgram++getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]+getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg+  where+    version = fromMaybe (error "GHC.getGhcInfo: no ghc version") $ programVersion ghcProg+    implInfo = ghcVersionImplInfo version++-- | Given a single package DB, return all installed packages.+getPackageDBContents+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBX (SymbolicPath from (Dir PkgDB))+  -> ProgramDb+  -> IO InstalledPackageIndex+getPackageDBContents verbosity mbWorkDir packagedb progdb = do+  pkgss <- getInstalledPackages' verbosity mbWorkDir [packagedb] progdb+  toPackageIndex verbosity pkgss progdb++-- | Given a package DB stack, return all installed packages.+getInstalledPackages+  :: Verbosity+  -> Compiler+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBStackX (SymbolicPath from (Dir PkgDB))+  -> ProgramDb+  -> IO InstalledPackageIndex+getInstalledPackages verbosity comp mbWorkDir packagedbs progdb = do+  checkPackageDbEnvVar verbosity+  checkPackageDbStack verbosity comp packagedbs+  pkgss <- getInstalledPackages' verbosity mbWorkDir packagedbs progdb+  index <- toPackageIndex verbosity pkgss progdb+  return $! hackRtsPackage index+  where+    hackRtsPackage index =+      case PackageIndex.lookupPackageName index (mkPackageName "rts") of+        [(_, [rts])] ->+          PackageIndex.insert (removeMingwIncludeDir rts) index+        _ -> index -- No (or multiple) ghc rts package is registered!!+        -- Feh, whatever, the ghc test suite does some crazy stuff.++-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a+-- @PackageIndex@. Helper function used by 'getPackageDBContents' and+-- 'getInstalledPackages'.+toPackageIndex+  :: Verbosity+  -> [(PackageDBX a, [InstalledPackageInfo])]+  -> ProgramDb+  -> IO InstalledPackageIndex+toPackageIndex verbosity pkgss progdb = do+  -- On Windows, various fields have $topdir/foo rather than full+  -- paths. We need to substitute the right value in so that when+  -- we, for example, call gcc, we have proper paths to give it.+  topDir <- getLibDir' verbosity ghcProg+  let indices =+        [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)+        | (_, pkgs) <- pkgss+        ]+  return $! mconcat indices+  where+    ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb++-- | Return the 'FilePath' to the GHC application data directory.+--+-- @since 3.4.0.0+getGhcAppDir :: IO FilePath+getGhcAppDir = getAppUserDataDirectory "ghc"++getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath+getLibDir verbosity lbi =+  dropWhileEndLE isSpace+    `fmap` getDbProgramOutput+      verbosity+      ghcProgram+      (withPrograms lbi)+      ["--print-libdir"]++getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath+getLibDir' verbosity ghcProg =+  dropWhileEndLE isSpace+    `fmap` getProgramOutput verbosity ghcProg ["--print-libdir"]++-- | Return the 'FilePath' to the global GHC package database.+getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath+getGlobalPackageDB verbosity ghcProg =+  dropWhileEndLE isSpace+    `fmap` getProgramOutput verbosity ghcProg ["--print-global-package-db"]++-- | Return the 'FilePath' to the per-user GHC package database.+getUserPackageDB+  :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath+getUserPackageDB _verbosity ghcProg platform = do+  -- It's rather annoying that we have to reconstruct this, because ghc+  -- hides this information from us otherwise. But for certain use cases+  -- like change monitoring it really can't remain hidden.+  appdir <- getGhcAppDir+  return (appdir </> platformAndVersion </> packageConfFileName)+  where+    platformAndVersion =+      Internal.ghcPlatformAndVersionString+        platform+        ghcVersion+    packageConfFileName = "package.conf.d"+    ghcVersion = fromMaybe (error "GHC.getUserPackageDB: no ghc version") $ programVersion ghcProg++checkPackageDbEnvVar :: Verbosity -> IO ()+checkPackageDbEnvVar verbosity =+  Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH"++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)+  | GlobalPackageDB `notElem` rest = return ()+checkPackageDbStackPost76 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'}++-- | Get the packages from specific PackageDBs, not cumulative.+getInstalledPackages'+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir from))+  -> [PackageDBX (SymbolicPath from (Dir PkgDB))]+  -> ProgramDb+  -> IO [(PackageDBX (SymbolicPath from (Dir PkgDB)), [InstalledPackageInfo])]+getInstalledPackages' verbosity mbWorkDir packagedbs progdb =+  sequenceA+    [ do+      pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity mbWorkDir packagedb+      return (packagedb, pkgs)+    | packagedb <- packagedbs+    ]++getInstalledPackagesMonitorFiles+  :: forall from+   . Verbosity+  -> Maybe (SymbolicPath CWD (Dir from))+  -> Platform+  -> ProgramDb+  -> [PackageDBS from]+  -> IO [FilePath]+getInstalledPackagesMonitorFiles verbosity mbWorkDir platform progdb =+  traverse getPackageDBPath+  where+    getPackageDBPath :: PackageDBS from -> IO FilePath+    getPackageDBPath GlobalPackageDB =+      selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg+    getPackageDBPath UserPackageDB =+      selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform+    getPackageDBPath (SpecificPackageDB path) = selectMonitorFile (interpretSymbolicPath mbWorkDir path)++    -- GHC has old style file dbs, and new style directory dbs.+    -- Note that for dir style dbs, we only need to monitor the cache file, not+    -- the whole directory. The ghc program itself only reads the cache file+    -- so it's safe to only monitor this one file.+    selectMonitorFile path0 = do+      let path =+            if isRelative path0+              then interpretSymbolicPath mbWorkDir (makeRelativePathEx path0)+              else path0+      isFileStyle <- doesFileExist path+      if isFileStyle+        then return path+        else return (path </> "package.cache")++    ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb++-- -----------------------------------------------------------------------------+-- Building a library++buildLib+  :: BuildFlags+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> Library+  -> ComponentLocalBuildInfo+  -> IO ()+buildLib flags numJobs pkg lbi lib clbi =+  GHC.build numJobs pkg $+    PreBuildComponentInputs+      { buildingWhat = BuildNormal flags+      , localBuildInfo = lbi+      , targetInfo = TargetInfo clbi (CLib lib)+      }++replLib+  :: ReplFlags+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> Library+  -> ComponentLocalBuildInfo+  -> IO ()+replLib flags numJobs pkg lbi lib clbi =+  GHC.build numJobs pkg $+    PreBuildComponentInputs+      { buildingWhat = BuildRepl flags+      , localBuildInfo = lbi+      , targetInfo = TargetInfo clbi (CLib lib)+      }++-- | Start a REPL without loading any source files.+startInterpreter+  :: Verbosity+  -> ProgramDb+  -> Compiler+  -> Platform+  -> PackageDBStack+  -> IO ()+startInterpreter verbosity progdb comp platform packageDBs = do+  let replOpts =+        mempty+          { ghcOptMode = toFlag GhcModeInteractive+          , ghcOptPackageDBs = packageDBs+          }+  checkPackageDbStack verbosity comp 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++-- -----------------------------------------------------------------------------+-- Building an executable or foreign library++-- | Build a foreign library+buildFLib+  :: Verbosity+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> ForeignLib+  -> ComponentLocalBuildInfo+  -> IO ()+buildFLib v numJobs pkg lbi flib clbi =+  GHC.build numJobs pkg $+    PreBuildComponentInputs+      { buildingWhat =+          BuildNormal $+            mempty+              { buildCommonFlags =+                  mempty{setupVerbosity = toFlag v}+              }+      , localBuildInfo = lbi+      , targetInfo = TargetInfo clbi (CFLib flib)+      }++replFLib+  :: ReplFlags+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> ForeignLib+  -> ComponentLocalBuildInfo+  -> IO ()+replFLib replFlags njobs pkg lbi flib clbi =+  GHC.build njobs pkg $+    PreBuildComponentInputs+      { buildingWhat = BuildRepl replFlags+      , localBuildInfo = lbi+      , targetInfo = TargetInfo clbi (CFLib flib)+      }++-- | Build an executable with GHC.+buildExe+  :: Verbosity+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> Executable+  -> ComponentLocalBuildInfo+  -> IO ()+buildExe v njobs pkg lbi exe clbi =+  GHC.build njobs pkg $+    PreBuildComponentInputs+      { buildingWhat =+          BuildNormal $+            mempty+              { buildCommonFlags =+                  mempty{setupVerbosity = toFlag v}+              }+      , localBuildInfo = lbi+      , targetInfo = TargetInfo clbi (CExe exe)+      }++replExe+  :: ReplFlags+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> Executable+  -> ComponentLocalBuildInfo+  -> IO ()+replExe replFlags njobs pkg lbi exe clbi =+  GHC.build njobs pkg $+    PreBuildComponentInputs+      { buildingWhat = BuildRepl replFlags+      , localBuildInfo = lbi+      , targetInfo = TargetInfo clbi (CExe exe)+      }++-- | Extracts a String representing a hash of the ABI of a built+-- library.  It can fail if the library has not yet been built.+libAbiHash+  :: Verbosity+  -> PackageDescription+  -> LocalBuildInfo+  -> Library+  -> ComponentLocalBuildInfo+  -> IO String+libAbiHash verbosity _pkg_descr lbi lib clbi = do+  let+    libBi = libBuildInfo lib+    comp = compiler lbi+    platform = hostPlatform lbi+    mbWorkDir = mbWorkDirLBI lbi+    vanillaArgs =+      (Internal.componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi))+        `mappend` mempty+          { ghcOptMode = toFlag GhcModeAbiHash+          , ghcOptInputModules = toNubListR $ exposedModules lib+          }+    sharedArgs =+      vanillaArgs+        `mappend` mempty+          { ghcOptDynLinkMode = toFlag GhcDynamicOnly+          , ghcOptFPic = toFlag True+          , ghcOptHiSuffix = toFlag "dyn_hi"+          , ghcOptObjSuffix = toFlag "dyn_o"+          , ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi+          }+    profArgs =+      vanillaArgs+        `mappend` mempty+          { ghcOptProfilingMode = toFlag True+          , ghcOptProfilingAuto =+              Internal.profDetailLevelFlag+                True+                (withProfLibDetail lbi)+          , ghcOptHiSuffix = toFlag "p_hi"+          , ghcOptObjSuffix = toFlag "p_o"+          , ghcOptExtra = hcOptions GHC libBi ++ hcProfOptions GHC libBi+          }+    profDynArgs =+      vanillaArgs+        `mappend` mempty+          { ghcOptProfilingMode = toFlag True+          , ghcOptProfilingAuto =+              Internal.profDetailLevelFlag+                True+                (withProfLibDetail lbi)+          , ghcOptDynLinkMode = toFlag GhcDynamicOnly+          , ghcOptFPic = toFlag True+          , ghcOptHiSuffix = toFlag "p_dyn_hi"+          , ghcOptObjSuffix = toFlag "p_dyn_o"+          , ghcOptExtra = hcOptions GHC libBi ++ hcProfSharedOptions GHC libBi+          }+    ghcArgs =+      let (libWays, _, _) = buildWays lbi+       in case libWays (componentIsIndefinite clbi) of+            (ProfDynWay : _) -> profDynArgs+            (ProfWay : _) -> profArgs+            (StaticWay : _) -> vanillaArgs+            (DynWay : _) -> sharedArgs+            _ -> error "libAbiHash: Can't find an enabled library way"++  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)++  hash <-+    getProgramInvocationOutput+      verbosity+      =<< ghcInvocation verbosity ghcProg comp platform mbWorkDir ghcArgs++  return (takeWhile (not . isSpace) hash)++-- -----------------------------------------------------------------------------+-- Installing++-- | Install executables for GHC.+installExe+  :: Verbosity+  -> LocalBuildInfo+  -> FilePath+  -- ^ Where to copy the files to+  -> FilePath+  -- ^ Build location+  -> (FilePath, FilePath)+  -- ^ Executable (prefix,suffix)+  -> PackageDescription+  -> Executable+  -> IO ()+installExe+  verbosity+  lbi+  binDir+  buildPref+  (progprefix, progsuffix)+  _pkg+  exe = do+    createDirectoryIfMissingVerbose verbosity True binDir+    let exeName' = unUnqualComponentName $ exeName exe+        exeFileName = exeTargetName (hostPlatform lbi) (exeName exe)+        fixedExeBaseName = progprefix ++ exeName' ++ progsuffix+        installBinary dest = do+          installExecutableFile+            verbosity+            (buildPref </> exeName' </> exeFileName)+            (dest <.> exeExtension (hostPlatform lbi))+          when (stripExes lbi) $+            Strip.stripExe+              verbosity+              (hostPlatform lbi)+              (withPrograms lbi)+              (dest <.> exeExtension (hostPlatform lbi))+    installBinary (binDir </> fixedExeBaseName)++-- | Install foreign library for GHC.+installFLib+  :: Verbosity+  -> LocalBuildInfo+  -> FilePath+  -- ^ install location+  -> FilePath+  -- ^ Build location+  -> PackageDescription+  -> ForeignLib+  -> IO ()+installFLib verbosity lbi targetDir builtDir _pkg flib =+  install+    (foreignLibIsShared flib)+    builtDir+    targetDir+    (flibTargetName lbi flib)+  where+    install isShared srcDir dstDir name = do+      let src = srcDir </> name+          dst = dstDir </> name+      createDirectoryIfMissingVerbose verbosity True targetDir+      -- TODO: Should we strip? (stripLibs lbi)+      if isShared+        then installExecutableFile verbosity src dst+        else installOrdinaryFile verbosity src dst+      -- Now install appropriate symlinks if library is versioned+      let (Platform _ os) = hostPlatform lbi+      when (not (null (foreignLibVersion flib os))) $ do+        when (os /= Linux) $+          dieWithException verbosity $+            CantInstallForeignLib+#ifndef mingw32_HOST_OS+        -- 'createSymbolicLink file1 file2' creates a symbolic link+        -- named 'file2' which points to the file 'file1'.+        -- Note that we do want a symlink to 'name' rather than+        -- 'dst', because the symlink will be relative to the+        -- directory it's created in.+        -- Finally, we first create the symlinks in a temporary+        -- directory and then rename to simulate 'ln --force'.+        withTempDirectory verbosity dstDir nm $ \tmpDir -> do+            let link1 = flibBuildName lbi flib+                link2 = "lib" ++ nm <.> "so"+            createSymbolicLink name (tmpDir </> link1)+            renameFile (tmpDir </> link1) (dstDir </> link1)+            createSymbolicLink name (tmpDir </> link2)+            renameFile (tmpDir </> link2) (dstDir </> link2)+      where+        nm :: String+        nm = unUnqualComponentName $ foreignLibName flib+#endif /* mingw32_HOST_OS */++-- | Install for ghc, .hi, .a and, if --with-ghci given, .o+installLib+  :: Verbosity+  -> LocalBuildInfo+  -> FilePath+  -- ^ install location+  -> FilePath+  -- ^ install location for dynamic libraries+  -> FilePath+  -- ^ Build location+  -> PackageDescription+  -> Library+  -> ComponentLocalBuildInfo+  -> IO ()+installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do+  let+    (wantedLibWays, _, _) = buildWays lbi+    isIndef = componentIsIndefinite clbi+    libWays = wantedLibWays isIndef++  info verbosity ("Wanted install ways: " ++ show libWays)++  -- copy .hi files over:+  forM_ (wantedLibWays isIndef) $ \w -> case w of+    StaticWay -> copyModuleFiles (Suffix "hi")+    DynWay -> copyModuleFiles (Suffix "dyn_hi")+    ProfWay -> copyModuleFiles (Suffix "p_hi")+    ProfDynWay -> copyModuleFiles (Suffix "p_dyn_hi")++  -- copy extra compilation artifacts that ghc plugins may produce+  copyDirectoryIfExists extraCompilationArtifacts++  -- copy the built library files over:+  when (has_code && hasLib) $ do+    forM_ libWays $ \w -> case w of+      StaticWay -> do+        sequence_+          [ installOrdinary+            builtDir+            targetDir+            (mkGenericStaticLibName (l ++ f))+          | l <-+              getHSLibraryName+                (componentUnitId clbi)+                : (extraBundledLibs (libBuildInfo lib))+          , f <- "" : extraLibFlavours (libBuildInfo lib)+          ]+        whenGHCi $ installOrdinary builtDir targetDir ghciLibName+      ProfWay -> do+        installOrdinary builtDir targetDir profileLibName+        whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName+      ProfDynWay -> do+        installShared+          builtDir+          dynlibTargetDir+          (mkProfSharedLibName platform compiler_id uid)+      DynWay -> do+        if+            -- The behavior for "extra-bundled-libraries" changed in version 2.5.0.+            -- See ghc issue #15837 and Cabal PR #5855.+            | specVersion pkg < CabalSpecV3_0 -> do+                sequence_+                  [ installShared+                    builtDir+                    dynlibTargetDir+                    (mkGenericSharedLibName platform compiler_id (l ++ f))+                  | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib)+                  , f <- "" : extraDynLibFlavours (libBuildInfo lib)+                  ]+            | otherwise -> do+                sequence_+                  [ installShared+                    builtDir+                    dynlibTargetDir+                    ( mkGenericSharedLibName+                        platform+                        compiler_id+                        (getHSLibraryName uid ++ f)+                    )+                  | f <- "" : extraDynLibFlavours (libBuildInfo lib)+                  ]+                sequence_+                  [ do+                    files <- getDirectoryContents (i builtDir)+                    let l' =+                          mkGenericSharedBundledLibName+                            platform+                            compiler_id+                            (l ++ f)+                    forM_ files $ \file ->+                      when (l' `isPrefixOf` file) $ do+                        isFile <- doesFileExist (i $ builtDir </> makeRelativePathEx file)+                        when isFile $ do+                          installShared+                            builtDir+                            dynlibTargetDir+                            file+                  | l <- extraBundledLibs (libBuildInfo lib)+                  , f <- "" : extraDynLibFlavours (libBuildInfo lib)+                  ]+  where+    -- See Note [Symbolic paths] in Distribution.Utils.Path+    i = interpretSymbolicPathLBI lbi++    builtDir = componentBuildDir lbi clbi+    mbWorkDir = mbWorkDirLBI lbi++    install isShared srcDir dstDir name = do+      let src = i $ srcDir </> makeRelativePathEx name+          dst = dstDir </> name++      createDirectoryIfMissingVerbose verbosity True dstDir++      if isShared+        then installExecutableFile verbosity src dst+        else installOrdinaryFile verbosity src dst++      when (stripLibs lbi) $+        Strip.stripLib+          verbosity+          platform+          (withPrograms lbi)+          dst++    installOrdinary = install False+    installShared = install True++    copyModuleFiles ext = do+      files <- findModuleFilesCwd verbosity mbWorkDir [builtDir] [ext] (allLibModules lib clbi)+      let files' = map (i *** getSymbolicPath) files+      installOrdinaryFiles verbosity targetDir files'++    copyDirectoryIfExists :: RelativePath Build (Dir Artifacts) -> IO ()+    copyDirectoryIfExists dirName = do+      let src = i $ builtDir </> dirName+          dst = targetDir </> getSymbolicPath dirName+      dirExists <- doesDirectoryExist src+      when dirExists $ copyDirectoryRecursive verbosity src dst++    compiler_id = compilerId (compiler lbi)+    platform = hostPlatform lbi+    uid = componentUnitId clbi+    profileLibName = mkProfLibName uid+    ghciLibName = Internal.mkGHCiLibName uid+    ghciProfLibName = Internal.mkGHCiProfLibName uid++    hasLib =+      not $+        null (allLibModules lib clbi)+          && null (cSources (libBuildInfo lib))+          && null (cxxSources (libBuildInfo lib))+          && null (cmmSources (libBuildInfo lib))+          && null (asmSources (libBuildInfo lib))+          && (null (jsSources (libBuildInfo lib)) || not hasJsSupport)+    hasJsSupport = case hostPlatform lbi of+      Platform JavaScript _ -> True+      _ -> False+    has_code = not (componentIsIndefinite clbi)+    whenGHCi = when (hasLib && withGHCiLib lbi && has_code)++-- -----------------------------------------------------------------------------+-- Registering++hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo+hcPkgInfo progdb =+  HcPkg.HcPkgInfo+    { HcPkg.hcPkgProgram = ghcPkgProg+    , HcPkg.noPkgDbStack = v < [6, 9]+    , HcPkg.noVerboseFlag = v < [6, 11]+    , HcPkg.flagPackageConf = v < [7, 5]+    , HcPkg.supportsDirDbs = v >= [6, 8]+    , HcPkg.requiresDirDbs = v >= [7, 10]+    , HcPkg.nativeMultiInstance = v >= [7, 10]+    , HcPkg.recacheMultiInstance = v >= [6, 12]+    , HcPkg.suppressFilesCheck = v >= [6, 6]+    }+  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++registerPackage+  :: Verbosity+  -> ProgramDb+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBStackS from+  -> InstalledPackageInfo+  -> HcPkg.RegisterOptions+  -> IO ()+registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions =+  HcPkg.register+    (hcPkgInfo progdb)+    verbosity+    mbWorkDir+    packageDbs+    installedPkgInfo+    registerOptions++pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO (SymbolicPath CWD (Dir Pkg))+pkgRoot verbosity lbi = fmap makeSymbolicPath . pkgRoot'+  where+    pkgRoot' GlobalPackageDB =+      let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi)+       in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg)+    pkgRoot' UserPackageDB = do+      appDir <- getGhcAppDir+      let ver = compilerVersion (compiler lbi)+          subdir =+            System.Info.arch+              ++ '-'+              : System.Info.os+              ++ '-'+              : prettyShow ver+          rootDir = appDir </> subdir+      -- We must create the root directory for the user package database if it+      -- does not yet exist. Otherwise '${pkgroot}' will resolve to a+      -- directory at the time of 'ghc-pkg register', and registration will+      -- fail.+      createDirectoryIfMissing True rootDir+      return rootDir+    pkgRoot' (SpecificPackageDB fp) =+      return $+        takeDirectory $+          interpretSymbolicPathLBI lbi fp
+ src/Distribution/Simple/GHC/Build.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DataKinds #-}++module Distribution.Simple.GHC.Build where++import Distribution.Compat.Prelude+import Prelude ()++import Control.Monad.IO.Class+import Distribution.PackageDescription as PD hiding (buildInfo)+import Distribution.Simple.Build.Inputs+import Distribution.Simple.Flag (Flag)+import Distribution.Simple.GHC.Build.ExtraSources+import Distribution.Simple.GHC.Build.Link+import Distribution.Simple.GHC.Build.Modules+import Distribution.Simple.GHC.Build.Utils (compilerBuildWay, isHaskell, withDynFLib)+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Program.Builtin (ghcProgram)+import Distribution.Simple.Program.Db (requireProgram)+import Distribution.Simple.Utils++import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.PackageName.Magic (fakePackageId)+import Distribution.Types.ParStrat+import Distribution.Utils.NubList (fromNubListR)+import Distribution.Utils.Path++import System.FilePath (splitDirectories)++{- Note [Build Target Dir vs Target Dir]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Where to place the build result (targetDir) and the build artifacts (buildTargetDir).++\* For libraries, targetDir == buildTargetDir, where both the library and+artifacts are put together.++\* For executables or foreign libs, buildTargetDir == targetDir/<name-of-target-dir>-tmp, where+    the targetDir is the location where the target (e.g. the executable) is written to+    and buildTargetDir is where the compilation artifacts (e.g. Main.o) will live+  Arguably, this difference should not exist (#9498) (TODO)++For instance, for a component `cabal-benchmarks`:+  targetDir == <buildDir>/cabal-benchmarks+  buildTargetDir == <buildDir>/cabal-benchmarks/cabal-benchmarks-tmp++Or, for a library `Cabal`:+  targetDir == <buildDir>/.+  buildTargetDir == targetDir++Furthermore, we need to account for the limit of characters in ghc+invocations that different OSes constrain us to. Cabal invocations can+rapidly reach this limit, in part, due to the long length of cabal v2+prefixes. To minimize the likelihood, we use+`tryMakeRelativeToWorkingDir` to shorten the paths used in invocations+(see da6321bb).++However, in executables, we don't do this. It seems that we don't need to do it+for executable-like components because the linking step, instead of passing as+an argument the path to each module, it simply passes the module name, the sources dir, and --make.+RM: I believe we can use --make + module names instead of paths-to-objects+for linking libraries too (2024-01) (TODO)+-}++-- | The main build phase of building a component.+-- Includes building Haskell modules, extra build sources, and linking.+build+  :: Flag ParStrat+  -> PackageDescription+  -> PreBuildComponentInputs+  -- ^ The context and component being built in it.+  -> IO ()+build numJobs pkg_descr pbci = do+  let+    verbosity = buildVerbosity pbci+    isLib = buildIsLib pbci+    lbi = localBuildInfo pbci+    bi = buildBI pbci+    clbi = buildCLBI pbci+    isIndef = componentIsIndefinite clbi+    mbWorkDir = mbWorkDirLBI lbi+    i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path++  -- Create a few directories for building the component+  -- See Note [Build Target Dir vs Target Dir]+  let targetDir0 :: SymbolicPath Pkg ('Dir Build)+      targetDir0 = componentBuildDir lbi clbi+      buildTargetDir0 :: SymbolicPath Pkg ('Dir Artifacts)+      buildTargetDir0+        -- Libraries use the target dir for building (see above)+        | isLib = coerceSymbolicPath targetDir0+        -- In other cases, use targetDir/<name-of-target-dir>-tmp+        | targetDirName : _ <- reverse $ splitDirectories $ getSymbolicPath targetDir0 =+            coerceSymbolicPath targetDir0 </> makeRelativePathEx (targetDirName ++ "-tmp")+        | otherwise = error "GHC.build: targetDir is empty"++  liftIO $ do+    createDirectoryIfMissingVerbose verbosity True $ i targetDir0+    createDirectoryIfMissingVerbose verbosity True $ i buildTargetDir0++  -- See Note [Build Target Dir vs Target Dir] as well+  let targetDir = targetDir0 -- NB: no 'makeRelative'+  buildTargetDir <-+    if isLib+      then -- NB: this might fail to make the buildTargetDir relative,+      -- as noted in #9776. Oh well.+        tryMakeRelative mbWorkDir buildTargetDir0+      else return buildTargetDir0+  -- To preserve the previous behaviour, we don't use relative dirs for+  -- executables. Historically, this isn't needed to reduce the CLI limit+  -- (unlike for libraries) because we link executables with the module names+  -- instead of passing the path to object file -- that's something else we+  -- can now fix after the refactor lands.++  (ghcProg, _) <- liftIO $ requireProgram verbosity ghcProgram (withPrograms lbi)++  -- Ways which are wanted from configuration flags+  let wantedWays@(wantedLibWays, wantedFLibWay, wantedExeWay) = buildWays lbi++  -- Ways which are needed due to the compiler configuration+  let doingTH = usesTemplateHaskellOrQQ bi+      defaultGhcWay = compilerBuildWay (buildCompiler pbci)+      wantedModBuildWays = case buildComponent pbci of+        CLib _ -> wantedLibWays isIndef+        CFLib fl -> [wantedFLibWay (withDynFLib fl)]+        CExe _ -> [wantedExeWay]+        CTest _ -> [wantedExeWay]+        CBench _ -> [wantedExeWay]+      finalModBuildWays =+        wantedModBuildWays+          ++ [defaultGhcWay | doingTH && defaultGhcWay `notElem` wantedModBuildWays]+      compNameStr = showComponentName $ componentName $ buildComponent pbci++  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+  let (hsMainFile, nonHsMainFile) =+        case mbMainFile of+          Just mainFile+            | PD.package pkg_descr == fakePackageId+                || isHaskell (getSymbolicPath mainFile) ->+                (Just mainFile, Nothing)+            | otherwise ->+                (Nothing, Just mainFile)+          Nothing -> (Nothing, Nothing)+  buildOpts <- buildHaskellModules numJobs ghcProg hsMainFile inputModules buildTargetDir finalModBuildWays pbci+  extraSources <- buildAllExtraSources nonHsMainFile ghcProg buildTargetDir wantedWays pbci+  linkOrLoadComponent+    ghcProg+    pkg_descr+    (fromNubListR extraSources)+    (buildTargetDir, targetDir)+    (wantedWays, buildOpts)+    pbci
+ src/Distribution/Simple/GHC/Build/ExtraSources.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++module Distribution.Simple.GHC.Build.ExtraSources where++import Control.Monad+import Data.Foldable+import Distribution.Simple.Flag+import qualified Distribution.Simple.GHC.Internal as Internal+import Distribution.Simple.Program.GHC+import Distribution.Simple.Utils+import Distribution.Utils.NubList++import Distribution.Types.BuildInfo+import Distribution.Types.Component+import Distribution.Types.TargetInfo++import Distribution.Simple.Build.Inputs+import Distribution.Simple.GHC.Build.Modules+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)++-- | An action that builds all the extra build sources of a component, i.e. C,+-- C++, Js, Asm, C-- sources.+buildAllExtraSources+  :: Maybe (SymbolicPath Pkg File)+  -- ^ An optional non-Haskell Main file+  -> ConfiguredProgram+  -- ^ The GHC configured program+  -> SymbolicPath Pkg (Dir Artifacts)+  -- ^ The build directory for this target+  -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)+  -- ^ Needed build ways+  -> PreBuildComponentInputs+  -- ^ The context and component being built in it.+  -> IO (NubListR (SymbolicPath Pkg File))+  -- ^ Returns the (nubbed) list of extra sources that were built+buildAllExtraSources =+  mconcat+    [ buildCSources+    , buildCxxSources+    , buildJsSources+    , buildAsmSources+    , buildCmmSources+    ]++buildCSources+  , buildCxxSources+  , buildJsSources+  , buildAsmSources+  , buildCmmSources+    :: Maybe (SymbolicPath Pkg File)+    -- ^ An optional non-Haskell Main file+    -> ConfiguredProgram+    -- ^ The GHC configured program+    -> SymbolicPath Pkg (Dir Artifacts)+    -- ^ The build directory for this target+    -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)+    -- ^ Needed build ways+    -> PreBuildComponentInputs+    -- ^ The context and component being built in it.+    -> IO (NubListR (SymbolicPath Pkg File))+    -- ^ Returns the list of extra sources that were built+buildCSources mbMainFile =+  buildExtraSources+    "C Sources"+    Internal.componentCcGhcOptions+    ( \c -> do+        let cFiles = cSources (componentBuildInfo c)+        case c of+          CExe{}+            | Just main <- mbMainFile+            , isC $ getSymbolicPath main ->+                cFiles ++ [main]+          _otherwise -> cFiles+    )+buildCxxSources mbMainFile =+  buildExtraSources+    "C++ Sources"+    Internal.componentCxxGhcOptions+    ( \c -> do+        let cxxFiles = cxxSources (componentBuildInfo c)+        case c of+          CExe{}+            | Just main <- mbMainFile+            , isCxx $ getSymbolicPath main ->+                cxxFiles ++ [main]+          _otherwise -> cxxFiles+    )+buildJsSources _mbMainFile ghcProg buildTargetDir neededWays = do+  Platform hostArch _ <- hostPlatform <$> localBuildInfo+  let hasJsSupport = hostArch == JavaScript+  buildExtraSources+    "JS Sources"+    Internal.componentJsGhcOptions+    ( \c ->+        if hasJsSupport+          then -- JS files are C-like with GHC's JS backend: they are+          -- "compiled" into `.o` files (renamed with a header).+          -- This is a difference from GHCJS, for which we only+          -- pass the JS files at link time.+            jsSources (componentBuildInfo c)+          else mempty+    )+    ghcProg+    buildTargetDir+    neededWays+buildAsmSources _mbMainFile =+  buildExtraSources+    "Assembler Sources"+    Internal.componentAsmGhcOptions+    (asmSources . componentBuildInfo)+buildCmmSources _mbMainFile =+  buildExtraSources+    "C-- Sources"+    Internal.componentCmmGhcOptions+    (cmmSources . componentBuildInfo)++-- | Create 'PreBuildComponentRules' for a given type of extra build sources+-- which are compiled via a GHC invocation with the given options. Used to+-- define built-in extra sources, such as, C, Cxx, Js, Asm, and Cmm sources.+buildExtraSources+  :: String+  -- ^ String describing the extra sources being built, for printing.+  -> ( Verbosity+       -> LocalBuildInfo+       -> BuildInfo+       -> ComponentLocalBuildInfo+       -> SymbolicPath Pkg (Dir Artifacts)+       -> SymbolicPath Pkg File+       -> GhcOptions+     )+  -- ^ Function to determine the @'GhcOptions'@ for the+  -- invocation of GHC when compiling these extra sources (e.g.+  -- @'Internal.componentCxxGhcOptions'@,+  -- @'Internal.componentCmmGhcOptions'@)+  -> (Component -> [SymbolicPath Pkg File])+  -- ^ View the extra sources of a component, typically from+  -- the build info (e.g. @'asmSources'@, @'cSources'@).+  -- @'Executable'@ components might additionally add the+  -- program entry point (@main-is@ file) to the extra sources,+  -- if it should be compiled as the rest of them.+  -> ConfiguredProgram+  -- ^ The GHC configured program+  -> SymbolicPath Pkg (Dir Artifacts)+  -- ^ The build directory for this target+  -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)+  -- ^ Needed build ways+  -> PreBuildComponentInputs+  -- ^ The context and component being built in it.+  -> IO (NubListR (SymbolicPath Pkg File))+  -- ^ Returns the list of extra sources that were built+buildExtraSources+  description+  componentSourceGhcOptions+  viewSources+  ghcProg+  buildTargetDir+  (neededLibWays, neededFLibWay, neededExeWay) =+    \PreBuildComponentInputs{buildingWhat, localBuildInfo = lbi, targetInfo} -> do+      let+        bi = componentBuildInfo (targetComponent targetInfo)+        verbosity = buildingWhatVerbosity buildingWhat+        clbi = targetCLBI targetInfo+        isIndef = componentIsIndefinite clbi+        mbWorkDir = mbWorkDirLBI lbi+        i = interpretSymbolicPath mbWorkDir+        sources = viewSources (targetComponent targetInfo)+        comp = compiler lbi+        platform = hostPlatform lbi+        tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags buildingWhat+        runGhcProg =+          runGHCWithResponseFile+            "ghc.rsp"+            Nothing+            tempFileOptions+            verbosity+            ghcProg+            comp+            platform+            mbWorkDir++        buildAction :: SymbolicPath Pkg File -> IO ()+        buildAction sourceFile = do+          let baseSrcOpts =+                componentSourceGhcOptions+                  verbosity+                  lbi+                  bi+                  clbi+                  buildTargetDir+                  sourceFile+              vanillaSrcOpts =+                -- -fPIC is used in case you are using the repl+                -- of a dynamically linked GHC+                baseSrcOpts{ghcOptFPic = toFlag True}+              profSrcOpts =+                vanillaSrcOpts+                  `mappend` mempty+                    { ghcOptProfilingMode = toFlag True+                    }+              sharedSrcOpts =+                vanillaSrcOpts+                  `mappend` mempty+                    { ghcOptFPic = toFlag True+                    , ghcOptDynLinkMode = toFlag GhcDynamicOnly+                    }+              profSharedSrcOpts =+                vanillaSrcOpts+                  `mappend` mempty+                    { ghcOptProfilingMode = toFlag True+                    , ghcOptFPic = toFlag True+                    , ghcOptDynLinkMode = toFlag GhcDynamicOnly+                    }+              -- TODO: Placing all Haskell, C, & C++ objects in a single directory+              --       Has the potential for file collisions. In general we would+              --       consider this a user error. However, we should strive to+              --       add a warning if this occurs.+              odir = fromFlag (ghcOptObjDir vanillaSrcOpts)++              compileIfNeeded :: GhcOptions -> IO ()+              compileIfNeeded opts = do+                needsRecomp <- checkNeedsRecompilation mbWorkDir sourceFile opts+                when needsRecomp $ runGhcProg opts++          createDirectoryIfMissingVerbose verbosity True (i odir)+          case targetComponent targetInfo of+            -- For libraries, we compile extra objects in the four ways: vanilla, shared, profiled and profiled shared.+            -- We suffix shared objects with `.dyn_o`, profiled ones with `.p_o` and profiled shared ones with `.p_dyn_o`.+            CLib _lib+              -- Unless for repl, in which case we only need the vanilla way+              | BuildRepl _ <- buildingWhat ->+                  compileIfNeeded vanillaSrcOpts+              | otherwise ->+                  do+                    forM_ (neededLibWays isIndef) $ \case+                      StaticWay -> compileIfNeeded vanillaSrcOpts+                      DynWay -> compileIfNeeded sharedSrcOpts{ghcOptObjSuffix = toFlag "dyn_o"}+                      ProfWay -> compileIfNeeded profSrcOpts{ghcOptObjSuffix = toFlag "p_o"}+                      ProfDynWay -> compileIfNeeded profSharedSrcOpts{ghcOptObjSuffix = toFlag "p_dyn_o"}+            CFLib flib ->+              case neededFLibWay (withDynFLib flib) of+                StaticWay -> compileIfNeeded vanillaSrcOpts+                DynWay -> compileIfNeeded sharedSrcOpts+                ProfWay -> compileIfNeeded profSrcOpts+                ProfDynWay -> compileIfNeeded profSharedSrcOpts+            -- For the remaining component types (Exec, Test, Bench), we also+            -- determine with which options to build the objects (vanilla vs shared vs+            -- profiled), but predicate is the same for the three kinds.+            _exeLike ->+              case neededExeWay of+                StaticWay -> compileIfNeeded vanillaSrcOpts+                DynWay -> compileIfNeeded sharedSrcOpts+                ProfWay -> compileIfNeeded profSrcOpts+                ProfDynWay -> compileIfNeeded profSharedSrcOpts++      -- build any sources+      if (null sources || componentIsIndefinite clbi)+        then return mempty+        else do+          info verbosity ("Building " ++ description ++ "...")+          traverse_ buildAction sources+          return (toNubListR sources)
+ src/Distribution/Simple/GHC/Build/Link.hs view
@@ -0,0 +1,812 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}++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)+import Distribution.Pretty+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.ImplInfo+import qualified Distribution.Simple.GHC.Internal as Internal+import Distribution.Simple.LocalBuildInfo+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PreProcess.Types+import Distribution.Simple.Program+import qualified Distribution.Simple.Program.Ar as Ar+import Distribution.Simple.Program.GHC+import qualified Distribution.Simple.Program.Ld as Ld+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Config+import Distribution.Simple.Setup.Repl+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Utils.NubList+import Distribution.Utils.Path+import Distribution.Verbosity+import Distribution.Version++import System.Directory+  ( createDirectoryIfMissing+  , doesDirectoryExist+  , doesFileExist+  , removeFile+  , renameFile+  )+import System.FilePath+  ( isRelative+  , replaceExtension+  )++-- | Links together the object files of the Haskell modules and extra sources+-- using the context in which the component is being built.+--+-- If the build kind is 'BuildRepl', we load the component into GHCi instead of linking.+linkOrLoadComponent+  :: ConfiguredProgram+  -- ^ The configured GHC program that will be used for linking+  -> PackageDescription+  -- ^ The package description containing the component being built+  -> [SymbolicPath Pkg File]+  -- ^ The full list of extra build sources (all C, C++, Js,+  -- Asm, and Cmm sources), which were compiled to object+  -- files.+  -> (SymbolicPath Pkg (Dir Artifacts), SymbolicPath Pkg (Dir Build))+  -- ^ The build target dir, and the target dir.+  -- See Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build+  -> ((Bool -> [BuildWay], Bool -> BuildWay, BuildWay), BuildWay -> GhcOptions)+  -- ^ The set of build ways wanted based on the user opts, and a function to+  -- convert a build way into the set of ghc options that were used to build+  -- that way.+  -> PreBuildComponentInputs+  -- ^ The context and component being built in it.+  -> IO ()+linkOrLoadComponent+  ghcProg+  pkg_descr+  extraSources+  (buildTargetDir, targetDir)+  ((wantedLibWays, wantedFLibWay, wantedExeWay), buildOpts)+  pbci = do+    let+      verbosity = buildVerbosity pbci+      target = targetInfo pbci+      component = buildComponent pbci+      what = buildingWhat pbci+      lbi = localBuildInfo pbci+      bi = buildBI pbci+      clbi = buildCLBI pbci+      isIndef = componentIsIndefinite clbi+      mbWorkDir = mbWorkDirLBI lbi+      tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags what++      -- See Note [Symbolic paths] in Distribution.Utils.Path+      i = interpretSymbolicPathLBI lbi++    -- ensure extra lib dirs exist before passing to ghc+    cleanedExtraLibDirs <- liftIO $ filterM (doesDirectoryExist . i) (extraLibDirs bi)+    cleanedExtraLibDirsStatic <- liftIO $ filterM (doesDirectoryExist . i) (extraLibDirsStatic bi)++    let+      extraSourcesObjs :: [RelativePath Artifacts File]+      extraSourcesObjs =+        [ makeRelativePathEx $ getSymbolicPath src `replaceExtension` objExtension+        | src <- extraSources+        ]++      -- TODO: Shouldn't we use withStaticLib for libraries and something else+      -- for foreign libs in the three cases where we use `withFullyStaticExe` below?+      linkerOpts rpaths =+        mempty+          { ghcOptLinkOptions =+              PD.ldOptions bi+                ++ [ "-static"+                   | withFullyStaticExe lbi+                   ]+                -- Pass extra `ld-options` given+                -- through to GHC's linker.+                ++ maybe+                  []+                  programOverrideArgs+                  (lookupProgram ldProgram (withPrograms lbi))+          , ghcOptLinkLibs =+              if withFullyStaticExe lbi+                then extraLibsStatic bi+                else extraLibs bi+          , ghcOptLinkLibPath =+              toNubListR $+                if withFullyStaticExe lbi+                  then cleanedExtraLibDirsStatic+                  else cleanedExtraLibDirs+          , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks bi+          , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs bi+          , ghcOptInputFiles =+              toNubListR+                [ coerceSymbolicPath $ buildTargetDir </> obj+                | obj <- extraSourcesObjs+                ]+          , ghcOptNoLink = Flag False+          , ghcOptRPaths = rpaths+          }++    case what of+      BuildRepl replFlags -> liftIO $ do+        let+          -- For repl we use the vanilla (static) ghc options+          staticOpts = buildOpts StaticWay+          replOpts =+            staticOpts+              { -- Repl options use Static as the base, but doesn't need to pass -static.+                -- However, it maybe should, for uniformity.+                ghcOptDynLinkMode = NoFlag+              , ghcOptExtra =+                  Internal.filterGhciFlags+                    (ghcOptExtra staticOpts)+                    <> replOptionsFlags (replReplOptions replFlags)+              }+              -- For a normal compile we do separate invocations of ghc for+              -- compiling as for linking. But for repl we have to do just+              -- the one invocation, so that one has to include all the+              -- linker stuff too, like -l flags and any .o files from C+              -- files etc.+              --+              -- TODO: The repl doesn't use the runtime paths from linkerOpts+              -- (ghcOptRPaths), which looks like a bug. After the refactor we+              -- can fix this.+              `mappend` linkerOpts mempty+              `mappend` mempty+                { ghcOptMode = toFlag GhcModeInteractive+                , ghcOptOptimisation = toFlag GhcNoOptimisation+                }+          replOpts_final =+            replOpts+              { ghcOptInputModules = replNoLoad (replReplOptions replFlags) (ghcOptInputModules replOpts)+              , ghcOptInputFiles = replNoLoad (replReplOptions replFlags) (ghcOptInputFiles replOpts)+              }++        -- TODO: problem here is we need the .c files built first, so we can load them+        -- with ghci, but .c files can depend on .h files generated by ghc by ffi+        -- exports.+        when (case component of CLib lib -> null (allLibModules lib clbi); _ -> False) $+          warn verbosity "No exposed modules"+        runReplOrWriteFlags+          ghcProg+          lbi+          replFlags+          replOpts_final+          (pkgName (PD.package pkg_descr))+          target+      _otherwise ->+        let+          runGhcProg =+            runGHCWithResponseFile+              "ghc.rsp"+              Nothing+              tempFileOptions+              verbosity+              ghcProg+              comp+              platform+              mbWorkDir+          platform = hostPlatform lbi+          comp = compiler lbi+          get_rpaths ways =+            if DynWay `Set.member` ways then getRPaths pbci else return (toNubListR [])+         in+          when (not $ componentIsIndefinite clbi) $ do+            -- If not building dynamically, we don't pass any runtime paths.+            liftIO $ do+              info verbosity "Linking..."+              let linkExeLike name = do+                    rpaths <- get_rpaths (Set.singleton wantedExeWay)+                    linkExecutable (linkerOpts rpaths) (wantedExeWay, buildOpts) targetDir name runGhcProg lbi+              case component of+                CLib lib -> do+                  let libWays = wantedLibWays isIndef+                  rpaths <- get_rpaths (Set.fromList libWays)+                  linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths libWays+                CFLib flib -> do+                  let flib_way = wantedFLibWay (withDynFLib flib)+                  rpaths <- get_rpaths (Set.singleton flib_way)+                  linkFLib flib bi lbi (linkerOpts rpaths) (flib_way, buildOpts) targetDir runGhcProg+                CExe exe -> linkExeLike (exeName exe)+                CTest test -> linkExeLike (testName test)+                CBench bench -> linkExeLike (benchmarkName bench)++-- | Link a library component+linkLibrary+  :: SymbolicPath Pkg (Dir Artifacts)+  -- ^ 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+  -> Library+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> [SymbolicPath Pkg File]+  -- ^ Extra build sources (that were compiled to objects)+  -> NubListR FilePath+  -- ^ A list with the runtime-paths (rpaths), or empty if not linking dynamically+  -> [BuildWay]+  -- ^ Wanted build ways and corresponding build options+  -> IO ()+linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr 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 =+      buildTargetDir+        </> makeRelativePathEx (mkSharedLibName (hostPlatform lbi) compiler_id uid)+    profSharedLibFilePath =+      buildTargetDir+        </> makeRelativePathEx (mkProfSharedLibName (hostPlatform lbi) compiler_id uid)+    staticLibFilePath =+      buildTargetDir+        </> makeRelativePathEx (mkStaticLibName (hostPlatform lbi) 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 =+      mconcat+        [ Internal.getHaskellObjects+            implInfo+            lib+            lbi+            clbi+            buildTargetDir+            (buildWayPrefix way ++ objExtension)+            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"+              ]+        ]++    -- 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+    -- -shared...). The downside to doing this is that GHC would have to+    -- reconstruct the module graph again.+    -- That would mean linking the lib would be just like the executable, and+    -- we could more easily merge the two.+    --+    -- Right now, instead, we pass the path to each object file.+    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+        }++    -- After the relocation lib is created we invoke ghc -shared+    -- with the dependencies spelled out as -package arguments+    -- and ghc invokes the linker with the proper library paths+    ghcSharedLinkArgs :: [SymbolicPath Pkg File] -> GhcOptions+    ghcSharedLinkArgs dynObjectFiles =+      ghcBaseLinkArgs+        { ghcOptShared = toFlag True+        , ghcOptDynLinkMode = toFlag GhcDynamicOnly+        , ghcOptInputFiles = toNubListR $ 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+        , ghcOptLinkLibs = extraLibs libBi+        , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs+        , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi+        , ghcOptLinkFrameworkDirs =+            toNubListR $ PD.extraFrameworkDirs libBi+        , ghcOptRPaths = rpaths+        }+    ghcProfSharedLinkArgs pdynObjectFiles =+      ghcBaseLinkArgs+        { ghcOptShared = toFlag True+        , ghcOptProfilingMode = toFlag True+        , ghcOptProfilingAuto =+            Internal.profDetailLevelFlag+              True+              (withProfLibDetail lbi)+        , ghcOptDynLinkMode = toFlag GhcDynamicOnly+        , ghcOptInputFiles = toNubListR pdynObjectFiles+        , ghcOptOutputFile = toFlag profSharedLibFilePath+        , -- 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+        , ghcOptLinkLibs = extraLibs libBi+        , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs+        , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi+        , ghcOptLinkFrameworkDirs =+            toNubListR $ PD.extraFrameworkDirs libBi+        , ghcOptRPaths = rpaths+        }+    ghcStaticLinkArgs staticObjectFiles =+      ghcBaseLinkArgs+        { ghcOptStaticLib = toFlag True+        , ghcOptInputFiles = toNubListR $ map coerceSymbolicPath staticObjectFiles+        , ghcOptOutputFile = toFlag staticLibFilePath+        , ghcOptLinkLibs = extraLibs libBi+        , -- TODO: Shouldn't this use cleanedExtraLibDirsStatic instead?+          ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs+        }++  staticObjectFiles <- getObjFiles StaticWay+  profObjectFiles <- getObjFiles ProfWay+  dynamicObjectFiles <- getObjFiles DynWay+  profDynamicObjectFiles <- getObjFiles ProfDynWay++  let+    linkWay = \case+      ProfWay -> do+        Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles+        when (withGHCiLib lbi) $ do+          (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)+          Ld.combineObjectFiles+            verbosity+            lbi+            ldProg+            ghciProfLibFilePath+            profObjectFiles+      ProfDynWay -> do+        runGhcProg $ ghcProfSharedLinkArgs profDynamicObjectFiles+      DynWay -> do+        runGhcProg $ ghcSharedLinkArgs dynamicObjectFiles+      StaticWay -> do+        when (withVanillaLib lbi) $ do+          Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles+          when (withGHCiLib lbi) $ do+            (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)+            Ld.combineObjectFiles+              verbosity+              lbi+              ldProg+              ghciLibFilePath+              staticObjectFiles+        when (withStaticLib lbi) $ do+          runGhcProg $ ghcStaticLinkArgs staticObjectFiles++  -- 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)))+    traverse_ linkWay wantedWays++-- | Link the executable resulting from building this component, be it an+-- executable, test, or benchmark component.+linkExecutable+  :: (GhcOptions)+  -- ^ The linker-specific GHC options+  -> (BuildWay, BuildWay -> GhcOptions)+  -- ^ The wanted build ways and corresponding GhcOptions that were+  -- used to compile the modules in that way.+  -> SymbolicPath Pkg (Dir Build)+  -- ^ The target dir (2024-01:note: not the same as build target+  -- dir, see Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build)+  -> UnqualComponentName+  -- ^ Name of executable-like target+  -> (GhcOptions -> IO ())+  -- ^ Run the configured GHC program+  -> LocalBuildInfo+  -> IO ()+linkExecutable linkerOpts (way, buildOpts) targetDir targetName runGhcProg lbi = do+  let baseOpts = buildOpts way+      linkOpts =+        baseOpts+          `mappend` linkerOpts+          `mappend` mempty+            { -- If there are no input Haskell files we pass -no-hs-main, and+              -- assume there is a main function in another non-haskell object+              ghcOptLinkNoHsMain = toFlag (ghcOptInputFiles baseOpts == mempty && ghcOptInputScripts baseOpts == mempty)+            }+      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+linkFLib+  :: ForeignLib+  -> BuildInfo+  -> LocalBuildInfo+  -> (GhcOptions)+  -- ^ The linker-specific GHC options+  -> (BuildWay, BuildWay -> GhcOptions)+  -- ^ The wanted build ways and corresponding GhcOptions that were+  -- used to compile the modules in that way.+  -> SymbolicPath Pkg (Dir Build)+  -- ^ The target dir (2024-01:note: not the same as build target+  -- dir, see Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build)+  -> (GhcOptions -> IO ())+  -- ^ Run the configured GHC program+  -> IO ()+linkFLib flib bi lbi linkerOpts (way, buildOpts) targetDir runGhcProg = do+  let+    comp = compiler lbi++    -- Instruct GHC to link against libHSrts.+    rtsLinkOpts :: GhcOptions+    rtsLinkOpts+      | supportsFLinkRts =+          mempty+            { ghcOptLinkRts = toFlag True+            }+      | otherwise =+          mempty+            { ghcOptLinkLibs = rtsOptLinkLibs+            , ghcOptLinkLibPath = toNubListR $ map makeSymbolicPath $ rtsLibPaths rtsInfo+            }+      where+        threaded = hasThreaded bi+        supportsFLinkRts = compilerVersion comp >= mkVersion [9, 0]+        rtsInfo = extractRtsInfo lbi+        rtsOptLinkLibs =+          [ if withDynFLib flib+              then+                if threaded+                  then dynRtsThreadedLib (rtsDynamicInfo rtsInfo)+                  else dynRtsVanillaLib (rtsDynamicInfo rtsInfo)+              else+                if threaded+                  then statRtsThreadedLib (rtsStaticInfo rtsInfo)+                  else statRtsVanillaLib (rtsStaticInfo rtsInfo)+          ]++    linkOpts :: GhcOptions+    linkOpts = case foreignLibType flib of+      ForeignLibNativeShared ->+        (buildOpts way)+          `mappend` linkerOpts+          `mappend` rtsLinkOpts+          `mappend` mempty+            { ghcOptLinkNoHsMain = toFlag True+            , ghcOptShared = toFlag True+            , ghcOptFPic = toFlag True+            , ghcOptLinkModDefFiles = toNubListR $ fmap getSymbolicPath $ foreignLibModDefFile flib+            }+      ForeignLibNativeStatic ->+        -- this should be caught by buildFLib+        -- (and if we do implement this, we probably don't even want to call+        -- ghc here, but rather Ar.createArLibArchive or something)+        cabalBug "static libraries not yet implemented"+      ForeignLibTypeUnknown ->+        cabalBug "unknown foreign lib type"+  -- We build under a (potentially) different filename to set a+  -- soname on supported platforms.  See also the note for+  -- @flibBuildName@.+  let buildName = flibBuildName lbi flib+  let outFile = targetDir </> makeRelativePathEx buildName+  runGhcProg linkOpts{ghcOptOutputFile = toFlag outFile}+  let i = interpretSymbolicPathLBI lbi+  renameFile (i outFile) (i targetDir </> flibTargetName lbi flib)++-- | Calculate the RPATHs for the component we are building.+--+-- Calculates relative RPATHs when 'relocatable' is set.+getRPaths+  :: PreBuildComponentInputs+  -- ^ The context and component being built in it.+  -> IO (NubListR FilePath)+getRPaths pbci = do+  let+    lbi = localBuildInfo pbci+    bi = buildBI pbci+    clbi = buildCLBI pbci++    (Platform _ hostOS) = hostPlatform lbi+    compid = compilerId . compiler $ lbi++    -- The list of RPath-supported operating systems below reflects the+    -- platforms on which Cabal's RPATH handling is tested. It does _NOT_+    -- reflect whether the OS supports RPATH.++    -- E.g. when this comment was written, the *BSD operating systems were+    -- untested with regards to Cabal RPATH handling, and were hence set to+    -- 'False', while those operating systems themselves do support RPATH.+    supportRPaths Linux = True+    supportRPaths Windows = False+    supportRPaths OSX = True+    supportRPaths FreeBSD =+      case compid of+        CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True+        _ -> False+    supportRPaths OpenBSD = False+    supportRPaths NetBSD = False+    supportRPaths DragonFly = False+    supportRPaths Solaris = False+    supportRPaths AIX = False+    supportRPaths HPUX = False+    supportRPaths IRIX = False+    supportRPaths HaLVM = False+    supportRPaths IOS = False+    supportRPaths Android = False+    supportRPaths Ghcjs = False+    supportRPaths Wasi = False+    supportRPaths Hurd = True+    supportRPaths Haiku = False+    supportRPaths (OtherOS _) = False+  -- Do _not_ add a default case so that we get a warning here when a new OS+  -- is added.++  if supportRPaths hostOS+    then do+      libraryPaths <- liftIO $ depLibraryPaths False (relocatable lbi) lbi clbi+      let hostPref = case hostOS of+            OSX -> "@loader_path"+            _ -> "$ORIGIN"+          relPath p = if isRelative p then hostPref </> p else p+          rpaths =+            toNubListR (map relPath libraryPaths)+              <> toNubListR (map getSymbolicPath $ extraLibDirs bi)+      return rpaths+    else return mempty++data DynamicRtsInfo = DynamicRtsInfo+  { dynRtsVanillaLib :: FilePath+  , dynRtsThreadedLib :: FilePath+  , dynRtsDebugLib :: FilePath+  , dynRtsEventlogLib :: FilePath+  , dynRtsThreadedDebugLib :: FilePath+  , dynRtsThreadedEventlogLib :: FilePath+  }++data StaticRtsInfo = StaticRtsInfo+  { statRtsVanillaLib :: FilePath+  , statRtsThreadedLib :: FilePath+  , statRtsDebugLib :: FilePath+  , statRtsEventlogLib :: FilePath+  , statRtsThreadedDebugLib :: FilePath+  , statRtsThreadedEventlogLib :: FilePath+  , statRtsProfilingLib :: FilePath+  , statRtsThreadedProfilingLib :: FilePath+  }++data RtsInfo = RtsInfo+  { rtsDynamicInfo :: DynamicRtsInfo+  , rtsStaticInfo :: StaticRtsInfo+  , rtsLibPaths :: [FilePath]+  }++-- | Extract (and compute) information about the RTS library+--+-- TODO: This hardcodes the name as @HSrts-ghc<version>@. I don't know if we can+-- find this information somewhere. We can lookup the 'hsLibraries' field of+-- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which+-- doesn't really help.+extractRtsInfo :: LocalBuildInfo -> RtsInfo+extractRtsInfo lbi =+  case PackageIndex.lookupPackageName+    (installedPkgs lbi)+    (mkPackageName "rts") of+    [(_, [rts])] -> aux rts+    _otherwise -> error "No (or multiple) ghc rts package is registered"+  where+    aux :: InstalledPackageInfo -> RtsInfo+    aux rts =+      RtsInfo+        { rtsDynamicInfo =+            DynamicRtsInfo+              { dynRtsVanillaLib = withGhcVersion "HSrts"+              , dynRtsThreadedLib = withGhcVersion "HSrts_thr"+              , dynRtsDebugLib = withGhcVersion "HSrts_debug"+              , dynRtsEventlogLib = withGhcVersion "HSrts_l"+              , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug"+              , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l"+              }+        , rtsStaticInfo =+            StaticRtsInfo+              { statRtsVanillaLib = "HSrts"+              , statRtsThreadedLib = "HSrts_thr"+              , statRtsDebugLib = "HSrts_debug"+              , statRtsEventlogLib = "HSrts_l"+              , statRtsThreadedDebugLib = "HSrts_thr_debug"+              , statRtsThreadedEventlogLib = "HSrts_thr_l"+              , statRtsProfilingLib = "HSrts_p"+              , statRtsThreadedProfilingLib = "HSrts_thr_p"+              }+        , rtsLibPaths = InstalledPackageInfo.libraryDirs rts+        }+    withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi))))++-- | Determine whether the given 'BuildInfo' is intended to link against the+-- 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+  where+    PerCompilerFlavor ghc _ = options bi++-- | Load a target component into a repl, or write to disk a script which runs+-- GHCi with the GHC options Cabal elaborated to load the component interactively.+runReplOrWriteFlags+  :: ConfiguredProgram+  -> LocalBuildInfo+  -> ReplFlags+  -> GhcOptions+  -> PackageName+  -> TargetInfo+  -> IO ()+runReplOrWriteFlags ghcProg 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+      tempFileOptions = commonSetupTempFileOptions common+   in case replOptionsFlagOutput (replReplOptions rflags) of+        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 =+                [ (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+              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")+          -- Write out the PATH information into `paths` subdirectory.+          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 $+                extra_opts+                  ++ renderGhcOptions comp platform (ghcOpts{ghcOptMode = NoFlag})+                  ++ programOverrideArgs ghcProg++replNoLoad :: Ord a => ReplOptions -> NubListR a -> NubListR a+replNoLoad replFlags l+  | replOptionsNoLoad replFlags == Flag True = mempty+  | otherwise = l
+ src/Distribution/Simple/GHC/Build/Modules.hs view
@@ -0,0 +1,418 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++module Distribution.Simple.GHC.Build.Modules+  ( buildHaskellModules+  , BuildWay (..)+  , buildWayPrefix+  , componentInputs+  ) where++import Control.Monad.IO.Class+import Distribution.Compat.Prelude++import Data.List (sortOn, (\\))+import qualified Data.Set as Set+import Distribution.CabalSpecVersion+import Distribution.ModuleName (ModuleName)+import qualified Distribution.PackageDescription as PD+import Distribution.Pretty+import Distribution.Simple.Build.Inputs+import Distribution.Simple.BuildWay+import Distribution.Simple.Compiler+import Distribution.Simple.GHC.Build.Utils+import qualified Distribution.Simple.GHC.Internal as Internal+import qualified Distribution.Simple.Hpc as Hpc+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Program.GHC+import Distribution.Simple.Program.Types+import Distribution.Simple.Setup.Common+import Distribution.Simple.Utils+import Distribution.Types.Benchmark+import Distribution.Types.BenchmarkInterface+import Distribution.Types.BuildInfo+import Distribution.Types.Executable+import Distribution.Types.ForeignLib+import Distribution.Types.PackageName.Magic+import Distribution.Types.ParStrat+import Distribution.Types.TestSuite+import Distribution.Types.TestSuiteInterface+import Distribution.Utils.NubList+import Distribution.Utils.Path+import System.FilePath ()++{-+Note [Building Haskell Modules accounting for TH]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++There are multiple ways in which we may want to build our Haskell modules:+  * The static way (-static)+  * 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 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.+This can happen because of Template Haskell.++When we're using Template Haskell, we /need/ to additionally build modules with+the used GHC's default/vanilla ABI. This is because the code that TH needs to+run at compile time needs to be the vanilla ABI so it can be loaded up and run+by the compiler. With dynamic-by-default GHC the TH object files loaded at+compile-time need to be .dyn_o instead of .o.++  * If the GHC is dynamic by default, that means we may need to also build+  the dynamic way in addition the wanted way.++  * If the GHC is static by default, we may need to build statically additionally.++Of course, if the /wanted/ way is the way additionally /needed/ for TH, we don't need to do extra work.++If it turns out that in the end we need to build both statically and+dynamically, we want to make use of GHC's -static -dynamic-too capability, which+builds modules in the two ways in a single invocation.++If --dynamic-too is not supported by the GHC, then we need to be careful about+the order in which modules are built. Specifically, we must first build the+modules for TH with the vanilla ABI, and only afterwards the desired+(non-default) ways.++A few examples:++To build an executable with profiling, with a dynamic by default GHC, and TH is used:+  * Build dynamic (needed) objects+  * Build profiled objects++To build a library with profiling and dynamically, with a static by default GHC, and TH is used:+  * Build dynamic (wanted) and static (needed) objects together with --dynamic-too+  * Build profiled objects++To build an executable statically, with a static by default GHC, regardless of whether TH is used:+  * Simply build static objects++-}++-- | Compile the Haskell modules of the component being built.+buildHaskellModules+  :: Flag ParStrat+  -- ^ The parallelism strategy (e.g. num of jobs)+  -> ConfiguredProgram+  -- ^ The GHC configured program+  -> Maybe (SymbolicPath Pkg File)+  -- ^ Optional path to a Haskell Main file to build+  -> [ModuleName]+  -- ^ The Haskell modules to build+  -> SymbolicPath Pkg ('Dir Artifacts)+  -- ^ The path to the build directory for this target, which+  -- has already been created.+  -> [BuildWay]+  -- ^ The set of needed build ways according to user options+  -> PreBuildComponentInputs+  -- ^ The context and component being built in it.+  -> IO (BuildWay -> GhcOptions)+  -- ^ Returns a mapping from build ways to the 'GhcOptions' used in the+  -- 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+  -- See Note [Building Haskell Modules accounting for TH]++  let+    verbosity = buildVerbosity pbci+    isLib = buildIsLib pbci+    clbi = buildCLBI pbci+    lbi = localBuildInfo pbci+    bi = buildBI pbci+    what = buildingWhat pbci+    comp = buildCompiler pbci+    i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path++    -- If this component will be loaded into a repl, we don't compile the modules at all.+    forRepl+      | BuildRepl{} <- what = True+      | otherwise = False++    -- TODO: do we need to put hs-boot files into place for mutually recursive+    -- modules?  FIX: what about exeName.hi-boot?++    -- Determine if program coverage should be enabled and if so, what+    -- '-hpcdir' should be.+    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++    mbWorkDir = mbWorkDirLBI lbi+    tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags what+    runGhcProg =+      runGHCWithResponseFile+        "ghc.rsp"+        Nothing+        tempFileOptions+        verbosity+        ghcProg+        comp+        platform+        mbWorkDir+    platform = hostPlatform lbi++    (hsMains, scriptMains) =+      partition (isHaskell . getSymbolicPath) (maybeToList mbMainFile)++    -- We define the base opts which are shared across different build ways in+    -- 'buildHaskellModules'+    baseOpts way =+      (Internal.componentGhcOptions verbosity lbi bi clbi buildTargetDir)+        `mappend` mempty+          { ghcOptMode = toFlag GhcModeMake+          , -- Previously we didn't pass -no-link when building libs,+            -- but I think that could result in a bug (e.g. if a lib module is+            -- called Main and exports main). So we really want nolink when+            -- building libs too (TODO).+            ghcOptNoLink = if isLib then NoFlag else toFlag True+          , ghcOptNumJobs = numJobs+          , ghcOptInputModules = toNubListR inputModules+          , ghcOptInputFiles = toNubListR hsMains+          , ghcOptInputScripts = toNubListR scriptMains+          , ghcOptExtra = buildWayExtraHcOptions way GHC bi+          , ghcOptHiSuffix = optSuffixFlag (buildWayPrefix way) "hi"+          , ghcOptObjSuffix = optSuffixFlag (buildWayPrefix way) "o"+          , ghcOptHPCDir = hpcdir (buildWayHpcWay way) -- maybe this should not be passed for vanilla?+          }+      where+        optSuffixFlag "" _ = NoFlag+        optSuffixFlag pre x = toFlag (pre ++ x)++    -- 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}+    dynOpts =+      (baseOpts DynWay)+        { ghcOptDynLinkMode = toFlag GhcDynamicOnly -- use -dynamic+        , -- TODO: Does it hurt to set -fPIC for executables?+          ghcOptFPic = toFlag True -- use -fPIC+        }+    profOpts =+      (baseOpts ProfWay)+        { ghcOptProfilingMode = toFlag True+        , ghcOptProfilingAuto =+            Internal.profDetailLevelFlag+              (if isLib then True else False)+              ((if isLib then withProfLibDetail else withProfExeDetail) lbi)+        }+    profDynOpts =+      (baseOpts ProfDynWay)+        { ghcOptDynLinkMode = toFlag GhcDynamicOnly -- use -dynamic+        , -- TODO: Does it hurt to set -fPIC for executables?+          ghcOptFPic = toFlag True -- use -fPIC+        , ghcOptProfilingMode = toFlag True+        , ghcOptProfilingAuto =+            Internal.profDetailLevelFlag+              (if isLib then True else False)+              ((if isLib then withProfLibDetail else withProfExeDetail) lbi)+        }++    -- Options for building both static and dynamic way at the same time, using+    -- the GHC flag -static and -dynamic-too+    dynTooOpts =+      (baseOpts StaticWay)+        { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic -- use -dynamic-too+        , ghcOptDynHiSuffix = toFlag (buildWayPrefix DynWay ++ "hi")+        , ghcOptDynObjSuffix = toFlag (buildWayPrefix DynWay ++ "o")+        , ghcOptHPCDir = hpcdir Hpc.Dyn+        -- Should we pass hcSharedOpts in the -dynamic-too ghc invocation?+        -- (Note that `baseOtps StaticWay = hcStaticOptions`, not hcSharedOpts)+        }++    profDynTooOpts =+      (baseOpts ProfWay)+        { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic -- use -dynamic-too+        , -- TODO: Does it hurt to set -fPIC for executables?+          ghcOptFPic = toFlag True -- use -fPIC+        , ghcOptProfilingMode = toFlag True+        , ghcOptProfilingAuto =+            Internal.profDetailLevelFlag+              (if isLib then True else False)+              ((if isLib then withProfLibDetail else withProfExeDetail) lbi)+        , ghcOptDynHiSuffix = toFlag (buildWayPrefix ProfDynWay ++ "hi")+        , ghcOptDynObjSuffix = toFlag (buildWayPrefix ProfDynWay ++ "o")+        , ghcOptHPCDir = hpcdir Hpc.ProfDyn+        -- Should we pass hcSharedOpts in the -dynamic-too ghc invocation?+        -- (Note that `baseOtps StaticWay = hcStaticOptions`, not hcSharedOpts)+        }++    -- Determines how to build for each way, also serves as the base options+    -- for loading modules in 'linkOrLoadComponent'+    buildOpts way = case way of+      StaticWay -> staticOpts+      DynWay -> dynOpts+      ProfWay -> profOpts+      ProfDynWay -> profDynOpts++  -- 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 =+        StaticWay `Set.member` neededLibWaysSet+          && DynWay `Set.member` neededLibWaysSet+          && supportsDynamicToo comp+          && null (hcSharedOptions GHC bi)++      useProfDynamicToo =+        ProfWay `Set.member` neededLibWaysSet+          && ProfDynWay `Set.member` neededLibWaysSet+          && supportsDynamicToo comp+          && null (hcSharedOptions GHC bi)++      defaultGhcWay = compilerBuildWay comp++      order w+        | w == defaultGhcWay = 0+        | otherwise = fromEnum w + 1++      -- The ways we'll build, in order+      orderedBuilds+        -- We need to make sure that the way which is the way the compiler is built+        -- is built first so that Template Haskell works.+        | useProfDynamicToo && useDynamicToo =+            if defaultGhcWay `elem` [ProfDynWay, ProfWay]+              then [buildProfAndProfDynamicToo, buildStaticAndDynamicToo]+              else [buildStaticAndDynamicToo, buildProfAndProfDynamicToo]+        | useProfDynamicToo && not useDynamicToo =+            if defaultGhcWay `elem` [ProfDynWay, ProfWay]+              then+                [buildProfAndProfDynamicToo]+                  ++ (runGhcProg . buildOpts <$> neededLibWays \\ [ProfDynWay, ProfWay])+              else+                (runGhcProg . buildOpts <$> neededLibWays \\ [ProfDynWay, ProfWay])+                  ++ [buildProfAndProfDynamicToo]+        | useDynamicToo =+            if defaultGhcWay `elem` [StaticWay, DynWay]+              then+                [buildStaticAndDynamicToo]+                  ++ (runGhcProg . buildOpts <$> neededLibWays \\ [StaticWay, DynWay])+              else+                (runGhcProg . buildOpts <$> neededLibWays \\ [StaticWay, DynWay])+                  ++ [buildStaticAndDynamicToo]+        -- Otherwise, we need to ensure the defaultGhcWay is built first+        | otherwise =+            runGhcProg . buildOpts <$> sortOn order neededLibWays++      buildStaticAndDynamicToo = do+        runGhcProg dynTooOpts+        case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of+          (Flag dynDir, Flag vanillaDir) ->+            -- When the vanilla and shared library builds are done+            -- in one pass, only one set of HPC module interfaces+            -- are generated. This set should suffice for both+            -- static and dynamically linked executables. We copy+            -- the modules interfaces so they are available under+            -- both ways.+            copyDirectoryRecursive verbosity (i dynDir) (i vanillaDir)+          _ -> return ()++      buildProfAndProfDynamicToo = do+        runGhcProg profDynTooOpts+        case (hpcdir Hpc.ProfDyn, hpcdir Hpc.Prof) of+          (Flag profDynDir, Flag profDir) ->+            -- When the vanilla and shared library builds are done+            -- in one pass, only one set of HPC module interfaces+            -- are generated. This set should suffice for both+            -- static and dynamically linked executables. We copy+            -- the modules interfaces so they are available under+            -- both ways.+            copyDirectoryRecursive verbosity (i profDynDir) (i profDir)+          _ -> return ()+     in+      -- REVIEW:ADD? info verbosity "Building Haskell Sources..."+      sequence_ orderedBuilds+  return buildOpts++-- | Returns the corresponding 'Hpc.Way' for a 'BuildWay'+buildWayHpcWay :: BuildWay -> Hpc.Way+buildWayHpcWay = \case+  StaticWay -> Hpc.Vanilla+  ProfWay -> Hpc.Prof+  DynWay -> Hpc.Dyn+  ProfDynWay -> Hpc.ProfDyn++-- | Returns a function to extract the extra haskell compiler options from a+-- 'BuildInfo' and 'CompilerFlavor'+buildWayExtraHcOptions :: BuildWay -> CompilerFlavor -> BuildInfo -> [String]+buildWayExtraHcOptions = \case+  StaticWay -> hcStaticOptions+  ProfWay -> hcProfOptions+  DynWay -> hcSharedOptions+  ProfDynWay -> hcProfSharedOptions++-- | Returns a pair of the main file and Haskell modules of the component being+-- built. The main file is not necessarily a Haskell file. It could also be+-- e.g. a C source, or, a Haskell repl script (that does not necessarily have+-- an extension).+--+-- The main file is Nothing if the component is not executable.+componentInputs+  :: SymbolicPath Pkg (Dir Artifacts)+  -- ^ Target build dir+  -> 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 =+  case component of+    CLib lib ->+      pure (Nothing, allLibModules lib clbi)+    CFLib flib ->+      pure (Nothing, foreignLibModules flib)+    CExe Executable{buildInfo = bi', modulePath} ->+      exeLikeInputs bi' modulePath+    CTest TestSuite{testBuildInfo = bi', testInterface = TestSuiteExeV10 _ mainFile} ->+      exeLikeInputs bi' mainFile+    CBench Benchmark{benchmarkBuildInfo = bi', benchmarkInterface = BenchmarkExeV10 _ mainFile} ->+      exeLikeInputs bi' mainFile+    CTest TestSuite{} -> error "testSuiteExeV10AsExe: wrong kind"+    CBench Benchmark{} -> error "benchmarkExeV10asExe: wrong kind"+  where+    verbosity = buildVerbosity pbci+    component = buildComponent pbci+    clbi = buildCLBI pbci+    mbWorkDir = mbWorkDirLBI $ localBuildInfo pbci+    exeLikeInputs bnfo modulePath = liftIO $ do+      main <- findExecutableMain verbosity mbWorkDir buildTargetDir (bnfo, modulePath)+      let mainModName = exeMainModuleName bnfo+          otherModNames = otherModules bnfo++      -- Scripts have fakePackageId and are always Haskell but can have any extension.+      if isHaskell (getSymbolicPath main) || PD.package pkg_descr == fakePackageId+        then+          if PD.specVersion pkg_descr < CabalSpecV2_0 && (mainModName `elem` otherModNames)+            then do+              -- The cabal manual clearly states that `other-modules` is+              -- intended for non-main modules.  However, there's at least one+              -- important package on Hackage (happy-1.19.5) which+              -- violates this. We workaround this here so that we don't+              -- invoke GHC with e.g.  'ghc --make Main src/Main.hs' which+              -- would result in GHC complaining about duplicate Main+              -- modules.+              --+              -- Finally, we only enable this workaround for+              -- specVersion < 2, as 'cabal-version:>=2.0' cabal files+              -- have no excuse anymore to keep doing it wrong... ;-)+              warn verbosity $+                "Enabling workaround for Main module '"+                  ++ prettyShow mainModName+                  ++ "' listed in 'other-modules' illegally!"+              return (Just main, filter (/= mainModName) otherModNames)+            else return (Just main, otherModNames)+        else return (Just main, otherModNames)
+ src/Distribution/Simple/GHC/Build/Utils.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}++module Distribution.Simple.GHC.Build.Utils where++import Distribution.Compat.Prelude+import Prelude ()++import Control.Monad (msum)+import Data.Char (isLower)+import Distribution.ModuleName (ModuleName)+import qualified Distribution.ModuleName as ModuleName+import Distribution.PackageDescription as PD+import Distribution.PackageDescription.Utils (cabalBug)+import Distribution.Simple.BuildPaths+import Distribution.Simple.BuildWay+import Distribution.Simple.Compiler+import qualified Distribution.Simple.GHC.Internal as Internal+import Distribution.Simple.Program.GHC+import Distribution.Simple.Setup.Common+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Types.LocalBuildInfo+  ( LocalBuildInfo (hostPlatform)+  )+import Distribution.Utils.Path+import Distribution.Verbosity+import System.FilePath+  ( replaceExtension+  , takeExtension+  )++-- | Find the path to the entry point of an executable (typically specified in+-- @main-is@, and found in @hs-source-dirs@ -- yes, even when @main-is@ is not a Haskell file).+findExecutableMain+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> SymbolicPath Pkg (Dir build)+  -- ^ Build directory+  -> (BuildInfo, RelativePath Source File)+  -- ^ The build info and module path of an executable-like component (Exe, Test, Bench)+  -> IO (SymbolicPath Pkg File)+  -- ^ The path to the main source file.+findExecutableMain verbosity mbWorkDir buildDir (bnfo, modPath) =+  findFileCwd verbosity mbWorkDir (coerceSymbolicPath buildDir : hsSourceDirs bnfo) modPath++-- | Does this compiler support the @-dynamic-too@ option+supportsDynamicToo :: Compiler -> Bool+supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"++compilerBuildWay :: Compiler -> BuildWay+compilerBuildWay c =+  case (isDynamic c, isProfiled c) of+    (True, True) -> ProfDynWay+    (True, False) -> DynWay+    (False, True) -> ProfWay+    (False, False) -> StaticWay++-- | Is this compiler's RTS dynamically linked?+isDynamic :: Compiler -> Bool+isDynamic = Internal.ghcLookupProperty "GHC Dynamic"++isProfiled :: Compiler -> Bool+isProfiled = Internal.ghcLookupProperty "GHC Profiled"++-- | Should we dynamically link the foreign library, based on its 'foreignLibType'?+withDynFLib :: ForeignLib -> Bool+withDynFLib flib =+  case foreignLibType flib of+    ForeignLibNativeShared ->+      ForeignLibStandalone `notElem` foreignLibOptions flib+    ForeignLibNativeStatic ->+      False+    ForeignLibTypeUnknown ->+      cabalBug "unknown foreign lib type"++-- | 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++"]++-- | Is this a C source file, i.e. ends with .c?+isC :: FilePath -> Bool+isC fp = elem (takeExtension fp) [".c"]++-- | FilePath has a Haskell extension: .hs or .lhs+isHaskell :: FilePath -> Bool+isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"]++-- | Returns True if the modification date of the given source file is newer than+-- the object file we last compiled for it, or if no object file exists yet.+checkNeedsRecompilation+  :: Maybe (SymbolicPath CWD (Dir Pkg))+  -> SymbolicPath Pkg File+  -> GhcOptions+  -> IO Bool+checkNeedsRecompilation mbWorkDir filename opts =+  i filename `moreRecentFile` oname+  where+    oname = getObjectFileName mbWorkDir filename opts+    i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path++-- | Finds the object file name of the given source file+getObjectFileName+  :: Maybe (SymbolicPath CWD (Dir Pkg))+  -> SymbolicPath Pkg File+  -> GhcOptions+  -> FilePath+getObjectFileName mbWorkDir filename opts = oname+  where+    i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path+    odir = i $ 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++-- | Target name for a foreign library (the actual file name)+--+-- We do not use mkLibName and co here because the naming for foreign libraries+-- is slightly different (we don't use "_p" or compiler version suffices, and we+-- don't want the "lib" prefix on Windows).+--+-- TODO: We do use `dllExtension` and co here, but really that's wrong: they+-- use the OS used to build cabal to determine which extension to use, rather+-- than the target OS (but this is wrong elsewhere in Cabal as well).+flibTargetName :: LocalBuildInfo -> ForeignLib -> String+flibTargetName lbi flib =+  case (os, foreignLibType flib) of+    (Windows, ForeignLibNativeShared) -> nm <.> "dll"+    (Windows, ForeignLibNativeStatic) -> nm <.> "lib"+    (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt+    (_other, ForeignLibNativeShared) ->+      "lib" ++ nm <.> dllExtension (hostPlatform lbi)+    (_other, ForeignLibNativeStatic) ->+      "lib" ++ nm <.> staticLibExtension (hostPlatform lbi)+    (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type"+  where+    nm :: String+    nm = unUnqualComponentName $ foreignLibName flib++    os :: OS+    Platform _ os = hostPlatform lbi++    -- If a foreign lib foo has lib-version-info 5:1:2 or+    -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1+    -- Libtool's version-info data is translated into library versions in a+    -- nontrivial way: so refer to libtool documentation.+    versionedExt :: String+    versionedExt =+      let nums = foreignLibVersion flib os+       in foldl (<.>) "so" (map show nums)++-- | Name for the library when building.+--+-- If the `lib-version-info` field or the `lib-version-linux` field of+-- a foreign library target is set, we need to incorporate that+-- version into the SONAME field.+--+-- If a foreign library foo has lib-version-info 5:1:2, it should be+-- built as libfoo.so.3.2.1.  We want it to get soname libfoo.so.3.+-- However, GHC does not allow overriding soname by setting linker+-- options, as it sets a soname of its own (namely the output+-- filename), after the user-supplied linker options.  Hence, we have+-- to compile the library with the soname as its filename.  We rename+-- the compiled binary afterwards.+--+-- This method allows to adjust the name of the library at build time+-- such that the correct soname can be set.+flibBuildName :: LocalBuildInfo -> ForeignLib -> String+flibBuildName lbi flib+  -- On linux, if a foreign-library has version data, the first digit is used+  -- to produce the SONAME.+  | (os, foreignLibType flib)+      == (Linux, ForeignLibNativeShared) =+      let nums = foreignLibVersion flib os+       in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums))+  | otherwise = flibTargetName lbi flib+  where+    os :: OS+    Platform _ os = hostPlatform lbi++    nm :: String+    nm = unUnqualComponentName $ foreignLibName flib++-- | Gets the target name (name of actual executable file) from the name of an+-- executable-like component ('Executable', 'TestSuite', 'Benchmark').+exeTargetName :: Platform -> UnqualComponentName -> String+exeTargetName platform name = unUnqualComponentName name `withExt` exeExtension platform+  where+    withExt :: FilePath -> String -> FilePath+    withExt fp ext = fp <.> if takeExtension fp /= ('.' : ext) then ext else ""++-- | "Main" module name when overridden by @ghc-options: -main-is ...@+-- or 'Nothing' if no @-main-is@ flag could be found.+--+-- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed.+exeMainModuleName+  :: BuildInfo+  -- ^ The build info of the executable-like component (Exe, Test, Bench)+  -> ModuleName+exeMainModuleName bnfo =+  -- GHC honors the last occurrence of a module name updated via -main-is+  --+  -- Moreover, -main-is when parsed left-to-right can update either+  -- the "Main" module name, or the "main" function name, or both,+  -- see also 'decodeMainIsArg'.+  fromMaybe ModuleName.main $ msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts+  where+    ghcopts = hcOptions GHC bnfo++    findIsMainArgs [] = []+    findIsMainArgs ("-main-is" : arg : rest) = arg : findIsMainArgs rest+    findIsMainArgs (_ : rest) = findIsMainArgs rest++-- | Decode argument to '-main-is'+--+-- Returns 'Nothing' if argument set only the function name.+--+-- This code has been stolen/refactored from GHC's DynFlags.setMainIs+-- function. The logic here is deliberately imperfect as it is+-- intended to be bug-compatible with GHC's parser. See discussion in+-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753.+decodeMainIsArg :: String -> Maybe ModuleName+decodeMainIsArg arg+  | headOf main_fn isLower =+      -- The arg looked like "Foo.Bar.baz"+      Just (ModuleName.fromString main_mod)+  | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar"+    =+      Just (ModuleName.fromString arg)+  | otherwise -- The arg looked like "baz"+    =+      Nothing+  where+    headOf :: String -> (Char -> Bool) -> Bool+    headOf str pred' = any pred' (safeHead str)++    (main_mod, main_fn) = splitLongestPrefix arg (== '.')++    splitLongestPrefix :: String -> (Char -> Bool) -> (String, String)+    splitLongestPrefix str pred'+      | null r_pre = (str, [])+      | otherwise = (reverse (safeTail r_pre), reverse r_suf)+      where+        -- 'safeTail' drops the char satisfying 'pred'+        (r_suf, r_pre) = break pred' (reverse str)
src/Distribution/Simple/GHC/EnvironmentParser.hs view
@@ -1,49 +1,53 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-module Distribution.Simple.GHC.EnvironmentParser-    ( parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc(..) ) where -import Prelude ()+module Distribution.Simple.GHC.EnvironmentParser (parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc (..)) where+ import Distribution.Compat.Prelude+import Prelude ()  import Distribution.Simple.Compiler-    ( PackageDB(..) ) import Distribution.Simple.GHC.Internal-    ( GhcEnvironmentFileEntry(..) )+  ( GhcEnvironmentFileEntry (..)+  ) import Distribution.Types.UnitId-    ( mkUnitId )+  ( mkUnitId+  )  import qualified Text.Parsec as P import Text.Parsec.String-    ( Parser, parseFromFile )+  ( Parser+  , parseFromFile+  ) -parseEnvironmentFileLine :: Parser GhcEnvironmentFileEntry-parseEnvironmentFileLine =      GhcEnvFileComment             <$> comment-                       <|>      GhcEnvFilePackageId           <$> unitId-                       <|>      GhcEnvFilePackageDb           <$> packageDb-                       <|> pure GhcEnvFileClearPackageDbStack <*  clearDb-    where-        comment = P.string "--" *> P.many (P.noneOf "\r\n")-        unitId = P.try $ P.string "package-id" *> P.spaces *>-            (mkUnitId <$> P.many1 (P.satisfy $ \c -> isAlphaNum c || c `elem` "-_.+"))-        packageDb = (P.string "global-package-db"      *> pure GlobalPackageDB)-                <|> (P.string "user-package-db"        *> pure UserPackageDB)-                <|> (P.string "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine))-        clearDb = P.string "clear-package-db"+parseEnvironmentFileLine :: Parser (GhcEnvironmentFileEntry FilePath)+parseEnvironmentFileLine =+  GhcEnvFileComment <$> comment+    <|> GhcEnvFilePackageId <$> unitId+    <|> GhcEnvFilePackageDb <$> packageDb+    <|> pure GhcEnvFileClearPackageDbStack <* clearDb+  where+    comment = P.string "--" *> P.many (P.noneOf "\r\n")+    unitId =+      P.try $+        P.string "package-id"+          *> P.spaces+          *> (mkUnitId <$> P.many1 (P.satisfy $ \c -> isAlphaNum c || c `elem` "-_.+"))+    packageDb =+      (P.string "global-package-db" *> pure GlobalPackageDB)+        <|> (P.string "user-package-db" *> pure UserPackageDB)+        <|> (P.string "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine))+    clearDb = P.string "clear-package-db"  newtype ParseErrorExc = ParseErrorExc P.ParseError-                      deriving (Show, Typeable)+  deriving (Show)  instance Exception ParseErrorExc -parseGhcEnvironmentFile :: Parser [GhcEnvironmentFileEntry]+parseGhcEnvironmentFile :: Parser [GhcEnvironmentFileEntry FilePath] parseGhcEnvironmentFile = parseEnvironmentFileLine `P.sepEndBy` P.endOfLine <* P.eof -readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry]+readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry FilePath] readGhcEnvironmentFile path =-    either (throwIO . ParseErrorExc) return =<<-        parseFromFile parseGhcEnvironmentFile path+  either (throwIO . ParseErrorExc) return+    =<< parseFromFile parseGhcEnvironmentFile path
src/Distribution/Simple/GHC/ImplInfo.hs view
@@ -1,4 +1,5 @@ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.GHC.ImplInfo --@@ -8,89 +9,127 @@ -- This module contains the data structure describing invocation -- details for a GHC or GHC-derived compiler, such as supported flags -- and workarounds for bugs.--module Distribution.Simple.GHC.ImplInfo (-        GhcImplInfo(..), getImplInfo,-        ghcVersionImplInfo, ghcjsVersionImplInfo-        ) where+module Distribution.Simple.GHC.ImplInfo+  ( GhcImplInfo (..)+  , getImplInfo+  , ghcVersionImplInfo+  , ghcjsVersionImplInfo+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import Distribution.Simple.Compiler import Distribution.Version -{- |-     Information about features and quirks of a GHC-based implementation.--     Compiler flavors based on GHC behave similarly enough that some of-     the support code for them is shared. Every implementation has its-     own peculiarities, that may or may not be a direct result of the-     underlying GHC version. This record keeps track of these differences.--     All shared code (i.e. everything not in the Distribution.Simple.FLAVOR-     module) should use implementation info rather than version numbers-     to test for supported features.--}-+-- |+--      Information about features and quirks of a GHC-based implementation.+--+--      Compiler flavors based on GHC behave similarly enough that some of+--      the support code for them is shared. Every implementation has its+--      own peculiarities, that may or may not be a direct result of the+--      underlying GHC version. This record keeps track of these differences.+--+--      All shared code (i.e. everything not in the Distribution.Simple.FLAVOR+--      module) should use implementation info rather than version numbers+--      to test for supported features. data GhcImplInfo = GhcImplInfo-  { supportsHaskell2010  :: Bool -- ^ -XHaskell2010 and -XHaskell98 flags-  , supportsGHC2021      :: Bool -- ^ -XGHC2021 flag-  , reportsNoExt         :: Bool -- ^ --supported-languages gives Ext and NoExt-  , alwaysNondecIndent   :: Bool -- ^ NondecreasingIndentation is always on-  , flagGhciScript       :: Bool -- ^ -ghci-script flag supported-  , flagProfAuto         :: Bool -- ^ new style -fprof-auto* flags-  , flagPackageConf      :: Bool -- ^ use package-conf instead of package-db-  , flagDebugInfo        :: Bool -- ^ -g flag supported-  , supportsDebugLevels  :: Bool -- ^ supports numeric @-g@ levels-  , supportsPkgEnvFiles  :: Bool -- ^ picks up @.ghc.environment@ files-  , flagWarnMissingHomeModules :: Bool -- ^ -Wmissing-home-modules is supported+  { supportsHaskell2010 :: Bool+  -- ^ -XHaskell2010 and -XHaskell98 flags+  , supportsGHC2021 :: Bool+  -- ^ -XGHC2021 flag+  , 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+  -- ^ -Wmissing-home-modules is supported+  , unitIdForExes :: Bool+  -- ^ Pass -this-unit-id flag when building executables   }  getImplInfo :: Compiler -> GhcImplInfo getImplInfo comp =   case compilerFlavor comp of-    GHC   -> ghcVersionImplInfo (compilerVersion comp)+    GHC -> ghcVersionImplInfo (compilerVersion comp)     GHCJS -> case compilerCompatVersion GHC comp of-              Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer-              _  -> error ("Distribution.Simple.GHC.Props.getImplProps: " ++-                           "could not find GHC version for GHCJS compiler")-    x     -> error ("Distribution.Simple.GHC.Props.getImplProps only works" ++-                    "for GHC-like compilers (GHC, GHCJS)" ++-                    ", but found " ++ show x)+      Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer+      _ ->+        error+          ( "Distribution.Simple.GHC.Props.getImplProps: "+              ++ "could not find GHC version for GHCJS compiler"+          )+    x ->+      error+        ( "Distribution.Simple.GHC.Props.getImplProps only works"+            ++ "for GHC-like compilers (GHC, GHCJS)"+            ++ ", but found "+            ++ show x+        )  ghcVersionImplInfo :: Version -> GhcImplInfo-ghcVersionImplInfo ver = GhcImplInfo-  { supportsHaskell2010  = v >= [7]-  , supportsGHC2021      = v >= [9,1]-  , reportsNoExt         = v >= [7]-  , alwaysNondecIndent   = v <  [7,1]-  , flagGhciScript       = v >= [7,2]-  , flagProfAuto         = v >= [7,4]-  , flagPackageConf      = v <  [7,5]-  , flagDebugInfo        = v >= [7,10]-  , supportsDebugLevels  = v >= [8,0]-  , supportsPkgEnvFiles  = v >= [8,0,1,20160901] -- broken in 8.0.1, fixed in 8.0.2-  , flagWarnMissingHomeModules = v >= [8,2]-  }+ghcVersionImplInfo ver =+  GhcImplInfo+    { supportsHaskell2010 = v >= [7]+    , supportsGHC2021 = v >= [9, 1]+    , 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]+    }   where     v = versionNumbers ver -ghcjsVersionImplInfo :: Version  -- ^ The GHCJS version-                     -> Version  -- ^ The GHC version-                     -> GhcImplInfo-ghcjsVersionImplInfo _ghcjsver ghcver = GhcImplInfo-  { supportsHaskell2010  = True-  , supportsGHC2021      = True-  , reportsNoExt         = True-  , alwaysNondecIndent   = False-  , flagGhciScript       = True-  , flagProfAuto         = True-  , flagPackageConf      = False-  , flagDebugInfo        = False-  , supportsDebugLevels  = ghcv >= [8,0]-  , supportsPkgEnvFiles  = ghcv >= [8,0,2] --TODO: check this works in ghcjs-  , flagWarnMissingHomeModules = ghcv >= [8,2]-  }+ghcjsVersionImplInfo+  :: Version+  -- ^ The GHCJS version+  -> Version+  -- ^ The GHC version+  -> GhcImplInfo+ghcjsVersionImplInfo _ghcjsver ghcver =+  GhcImplInfo+    { supportsHaskell2010 = True+    , supportsGHC2021 = True+    , supportsGHC2024 = ghcv >= [9, 9]+    , reportsNoExt = True+    , alwaysNondecIndent = False+    , flagGhciScript = True+    , flagProfAuto = True+    , flagProfLate = True+    , flagPackageConf = False+    , flagDebugInfo = False+    , 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]+    }   where     ghcv = versionNumbers ghcver
src/Distribution/Simple/GHC/Internal.hs view
@@ -1,686 +1,864 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.GHC.Internal--- Copyright   :  Isaac Jones 2003-2007------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module contains functions shared by GHC (Distribution.Simple.GHC)--- and GHC-derived compilers.--module Distribution.Simple.GHC.Internal (-        configureToolchain,-        getLanguages,-        getExtensions,-        targetPlatform,-        getGhcInfo,-        componentCcGhcOptions,-        componentCmmGhcOptions,-        componentCxxGhcOptions,-        componentAsmGhcOptions,-        componentGhcOptions,-        mkGHCiLibName,-        mkGHCiProfLibName,-        filterGhciFlags,-        ghcLookupProperty,-        getHaskellObjects,-        mkGhcOptPackages,-        substTopDir,-        checkPackageDbEnvVar,-        profDetailLevelFlag,-        -- * GHC platform and version strings-        ghcArchString,-        ghcOsString,-        ghcPlatformAndVersionString,-        -- * Constructing GHC environment files-        GhcEnvironmentFileEntry(..),-        writeGhcEnvironmentFile,-        simpleGhcEnvironmentFile,-        ghcEnvironmentFileName,-        renderGhcEnvironmentFile,-        renderGhcEnvironmentFileEntry,- ) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Simple.GHC.ImplInfo-import Distribution.Types.ComponentLocalBuildInfo-import Distribution.Backpack-import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.PackageDescription-import Distribution.Lex-import Distribution.Simple.Compiler-import Distribution.Simple.Program.GHC-import Distribution.Simple.Setup-import qualified Distribution.ModuleName as ModuleName-import Distribution.Simple.Program-import Distribution.Simple.LocalBuildInfo-import Distribution.Types.UnitId-import Distribution.Types.LocalBuildInfo-import Distribution.Types.TargetInfo-import Distribution.Simple.Utils-import Distribution.Simple.BuildPaths-import Distribution.System-import Distribution.Pretty ( prettyShow )-import Distribution.Parsec ( simpleParsec )-import Distribution.Utils.NubList ( toNubListR )-import Distribution.Verbosity-import Distribution.Compat.Stack-import Distribution.Version (Version)-import Distribution.Utils.Path-import Language.Haskell.Extension--import qualified Data.Map as Map-import qualified Data.ByteString.Lazy.Char8 as BS-import System.Directory         ( getDirectoryContents, getTemporaryDirectory )-import System.Environment       ( getEnv )-import System.FilePath          ( (</>), (<.>), takeExtension-                                , takeDirectory, takeFileName)-import System.IO                ( hClose, hPutStrLn )--targetPlatform :: [(String, String)] -> Maybe Platform-targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo---- | Adjust the way we find and configure gcc and ld----configureToolchain :: GhcImplInfo-                   -> ConfiguredProgram-                   -> Map String String-                   -> ProgramDb-                   -> ProgramDb-configureToolchain _implInfo ghcProg ghcInfo =-    addKnownProgram gccProgram {-      programFindLocation = findProg gccProgramName extraGccPath,-      programPostConf     = configureGcc-    }-  . addKnownProgram ldProgram {-      programFindLocation = findProg ldProgramName extraLdPath,-      programPostConf     = configureLd-    }-  . addKnownProgram arProgram {-      programFindLocation = findProg arProgramName extraArPath-    }-  . addKnownProgram stripProgram {-      programFindLocation = findProg stripProgramName extraStripPath-    }-  where-    compilerDir = takeDirectory (programPath ghcProg)-    base_dir     = takeDirectory compilerDir-    mingwBinDir = base_dir </> "mingw" </> "bin"-    isWindows   = case buildOS of Windows -> True; _ -> False-    binPrefix   = ""--    maybeName :: Program -> Maybe FilePath -> String-    maybeName prog   = maybe (programName prog) (dropExeExtension . takeFileName)--    gccProgramName   = maybeName gccProgram   mbGccLocation-    ldProgramName    = maybeName ldProgram    mbLdLocation-    arProgramName    = maybeName arProgram    mbArLocation-    stripProgramName = maybeName stripProgram mbStripLocation--    mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]-    mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath]-                                 | otherwise = mbDir-      where-        mbDir = maybeToList . fmap takeDirectory $ mbPath--    extraGccPath   = mkExtraPath mbGccLocation   windowsExtraGccDir-    extraLdPath    = mkExtraPath mbLdLocation    windowsExtraLdDir-    extraArPath    = mkExtraPath mbArLocation    windowsExtraArDir-    extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir--    -- on Windows finding and configuring ghc's gcc & binutils is a bit special-    (windowsExtraGccDir, windowsExtraLdDir,-     windowsExtraArDir, windowsExtraStripDir) =-          let b = mingwBinDir </> binPrefix-          in  (b, b, b, b)--    findProg :: String -> [FilePath]-             -> Verbosity -> ProgramSearchPath-             -> IO (Maybe (FilePath, [FilePath]))-    findProg progName extraPath v searchpath =-        findProgramOnSearchPath v searchpath' progName-      where-        searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath--    -- Read tool locations from the 'ghc --info' output. Useful when-    -- cross-compiling.-    mbGccLocation   = Map.lookup "C compiler command" ghcInfo-    mbLdLocation    = Map.lookup "ld command" ghcInfo-    mbArLocation    = Map.lookup "ar command" ghcInfo-    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"--    -- 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-    -- String.-    ---    -- We first try to parse as a [String] and if this fails then tokenize the-    -- flags ourself.-    getFlags :: String -> [String]-    getFlags key =-        case Map.lookup key ghcInfo of-          Nothing -> []-          Just flags-            | (flags', ""):_ <- reads flags -> flags'-            | otherwise -> tokenizeQuotedWords flags--    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    configureGcc _v gccProg = do-      return gccProg {-        programDefaultArgs = programDefaultArgs gccProg-                             ++ ccFlags ++ gccLinkerFlags-      }--    configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    configureLd v ldProg = do-      ldProg' <- configureLd' v ldProg-      return ldProg' {-        programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags-      }--    -- we need to find out if ld supports the -x flag-    configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    configureLd' verbosity ldProg = do-      tempDir <- getTemporaryDirectory-      ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->-             withTempFile tempDir ".o" $ \testofile testohnd -> do-               hPutStrLn testchnd "int foo() { return 0; }"-               hClose testchnd; hClose testohnd-               runProgram verbosity ghcProg-                          [ "-hide-all-packages"-                          , "-c", testcfile-                          , "-o", testofile-                          ]-               withTempFile tempDir ".o" $ \testofile' testohnd' ->-                 do-                   hClose testohnd'-                   _ <- getProgramOutput verbosity ldProg-                     ["-x", "-r", testofile, "-o", testofile']-                   return True-                 `catchIO`   (\_ -> return False)-                 `catchExit` (\_ -> return False)-      if ldx-        then return ldProg { programDefaultArgs = ["-x"] }-        else return ldProg--getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram-             -> IO [(Language, String)]-getLanguages _ implInfo _-  -- TODO: should be using --supported-languages rather than hard coding-  | supportsGHC2021 implInfo = return-    [ (GHC2021, "-XGHC2021")-    , (Haskell2010, "-XHaskell2010")-    , (Haskell98, "-XHaskell98")-    ]-  | supportsHaskell2010 implInfo = return [(Haskell98,   "-XHaskell98")-                                          ,(Haskell2010, "-XHaskell2010")]-  | otherwise                    = return [(Haskell98,   "")]--getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram-           -> IO [(String, String)]-getGhcInfo verbosity _implInfo ghcProg = do-      xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)-                 ["--info"]-      case reads xs of-        [(i, ss)]-          | all isSpace ss ->-              return i-        _ ->-          die' verbosity "Can't parse --info output of GHC"--getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram-              -> IO [(Extension, Maybe String)]-getExtensions verbosity implInfo ghcProg = do-    str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)-              ["--supported-languages"]-    let extStrs = if reportsNoExt implInfo-                  then lines str-                  else -- Older GHCs only gave us either Foo or NoFoo,-                       -- so we have to work out the other one ourselves-                       [ extStr''-                       | extStr <- lines str-                       , let extStr' = case extStr of-                                       'N' : 'o' : xs -> xs-                                       _              -> "No" ++ extStr-                       , extStr'' <- [extStr, extStr']-                       ]-    let extensions0 = [ (ext, Just $ "-X" ++ prettyShow ext)-                      | Just ext <- map simpleParsec extStrs ]-        extensions1 = if alwaysNondecIndent implInfo-                      then -- ghc-7.2 split NondecreasingIndentation off-                           -- into a proper extension. Before that it-                           -- was always on.-                           -- Since it was not a proper extension, it could-                           -- not be turned off, hence we omit a-                           -- DisableExtension entry here.-                           (EnableExtension NondecreasingIndentation, Nothing) :-                           extensions0-                      else extensions0-    return extensions1--componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo-                      -> BuildInfo -> ComponentLocalBuildInfo-                      -> FilePath -> FilePath-                      -> GhcOptions-componentCcGhcOptions verbosity _implInfo lbi bi clbi odir filename =-    mempty {-      -- Respect -v0, but don't crank up verbosity on GHC if-      -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!-      ghcOptVerbosity      = toFlag (min verbosity normal),-      ghcOptMode           = toFlag GhcModeCompile,-      ghcOptInputFiles     = toNubListR [filename],--      ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi-                                          ,autogenPackageModulesDir lbi-                                          ,odir]-                                          -- includes relative to the package-                                          ++ includeDirs bi-                                          -- potential includes generated by `configure'-                                          -- in the build directory-                                          ++ [buildDir lbi </> dir | dir <- includeDirs bi],-      ghcOptHideAllPackages= toFlag True,-      ghcOptPackageDBs     = withPackageDB lbi,-      ghcOptPackages       = toNubListR $ mkGhcOptPackages clbi,-      ghcOptCcOptions      = (case withOptimization lbi of-                                  NoOptimisation -> []-                                  _              -> ["-O2"]) ++-                             (case withDebugInfo lbi of-                                  NoDebugInfo   -> []-                                  MinimalDebugInfo -> ["-g1"]-                                  NormalDebugInfo  -> ["-g"]-                                  MaximalDebugInfo -> ["-g3"]) ++-                                  ccOptions bi,-      ghcOptObjDir         = toFlag odir-    }---componentCxxGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo-                      -> BuildInfo -> ComponentLocalBuildInfo-                      -> FilePath -> FilePath-                      -> GhcOptions-componentCxxGhcOptions verbosity _implInfo lbi bi clbi odir filename =-    mempty {-      -- Respect -v0, but don't crank up verbosity on GHC if-      -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!-      ghcOptVerbosity      = toFlag (min verbosity normal),-      ghcOptMode           = toFlag GhcModeCompile,-      ghcOptInputFiles     = toNubListR [filename],--      ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi-                                          ,autogenPackageModulesDir lbi-                                          ,odir]-                                          -- includes relative to the package-                                          ++ includeDirs bi-                                          -- potential includes generated by `configure'-                                          -- in the build directory-                                          ++ [buildDir lbi </> dir | dir <- includeDirs bi],-      ghcOptHideAllPackages= toFlag True,-      ghcOptPackageDBs     = withPackageDB lbi,-      ghcOptPackages       = toNubListR $ mkGhcOptPackages clbi,-      ghcOptCxxOptions     = (case withOptimization lbi of-                                  NoOptimisation -> []-                                  _              -> ["-O2"]) ++-                             (case withDebugInfo lbi of-                                  NoDebugInfo   -> []-                                  MinimalDebugInfo -> ["-g1"]-                                  NormalDebugInfo  -> ["-g"]-                                  MaximalDebugInfo -> ["-g3"]) ++-                                  cxxOptions bi,-      ghcOptObjDir         = toFlag odir-    }---componentAsmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo-                      -> BuildInfo -> ComponentLocalBuildInfo-                      -> FilePath -> FilePath-                      -> GhcOptions-componentAsmGhcOptions verbosity _implInfo lbi bi clbi odir filename =-    mempty {-      -- Respect -v0, but don't crank up verbosity on GHC if-      -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!-      ghcOptVerbosity      = toFlag (min verbosity normal),-      ghcOptMode           = toFlag GhcModeCompile,-      ghcOptInputFiles     = toNubListR [filename],--      ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi-                                          ,autogenPackageModulesDir lbi-                                          ,odir]-                                          -- includes relative to the package-                                          ++ includeDirs bi-                                          -- potential includes generated by `configure'-                                          -- in the build directory-                                          ++ [buildDir lbi </> dir | dir <- includeDirs bi],-      ghcOptHideAllPackages= toFlag True,-      ghcOptPackageDBs     = withPackageDB lbi,-      ghcOptPackages       = toNubListR $ mkGhcOptPackages clbi,-      ghcOptAsmOptions     = (case withOptimization lbi of-                                  NoOptimisation -> []-                                  _              -> ["-O2"]) ++-                             (case withDebugInfo lbi of-                                  NoDebugInfo   -> []-                                  MinimalDebugInfo -> ["-g1"]-                                  NormalDebugInfo  -> ["-g"]-                                  MaximalDebugInfo -> ["-g3"]) ++-                                  asmOptions bi,-      ghcOptObjDir         = toFlag odir-    }---componentGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo-                    -> BuildInfo -> ComponentLocalBuildInfo -> FilePath-                    -> GhcOptions-componentGhcOptions verbosity implInfo lbi bi clbi odir =-    mempty {-      -- Respect -v0, but don't crank up verbosity on GHC if-      -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!-      ghcOptVerbosity       = toFlag (min verbosity normal),-      ghcOptCabal           = toFlag True,-      ghcOptThisUnitId      = case clbi of-        LibComponentLocalBuildInfo { componentCompatPackageKey = pk }-          -> toFlag pk-        _ -> mempty,-      ghcOptThisComponentId = case clbi of-          LibComponentLocalBuildInfo { componentComponentId = cid-                                     , componentInstantiatedWith = insts } ->-              if null insts-                  then mempty-                  else toFlag cid-          _ -> mempty,-      ghcOptInstantiatedWith = case clbi of-        LibComponentLocalBuildInfo { componentInstantiatedWith = insts }-          -> insts-        _ -> [],-      ghcOptNoCode          = toFlag $ componentIsIndefinite clbi,-      ghcOptHideAllPackages = toFlag True,-      ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo,-      ghcOptPackageDBs      = withPackageDB lbi,-      ghcOptPackages        = toNubListR $ mkGhcOptPackages clbi,-      ghcOptSplitSections   = toFlag (splitSections lbi),-      ghcOptSplitObjs       = toFlag (splitObjs lbi),-      ghcOptSourcePathClear = toFlag True,-      ghcOptSourcePath      = toNubListR $ [odir] ++ (map getSymbolicPath (hsSourceDirs bi))-                                           ++ [autogenComponentModulesDir lbi clbi]-                                           ++ [autogenPackageModulesDir lbi],-      ghcOptCppIncludePath  = toNubListR $ [autogenComponentModulesDir lbi clbi-                                           ,autogenPackageModulesDir lbi-                                           ,odir]-                                           -- includes relative to the package-                                           ++ includeDirs bi-                                           -- potential includes generated by `configure'-                                           -- in the build directory-                                           ++ [buildDir lbi </> dir | dir <- includeDirs bi],-      ghcOptCppOptions      = cppOptions bi,-      ghcOptCppIncludes     = toNubListR $-                              [autogenComponentModulesDir lbi clbi </> cppHeaderName],-      ghcOptFfiIncludes     = toNubListR $ includes bi,-      ghcOptObjDir          = toFlag odir,-      ghcOptHiDir           = toFlag odir,-      ghcOptStubDir         = toFlag odir,-      ghcOptOutputDir       = toFlag odir,-      ghcOptOptimisation    = toGhcOptimisation (withOptimization lbi),-      ghcOptDebugInfo       = toFlag (withDebugInfo lbi),-      ghcOptExtra           = hcOptions GHC bi,-      ghcOptExtraPath       = toNubListR $ exe_paths,-      ghcOptLanguage        = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),-      -- Unsupported extensions have already been checked by configure-      ghcOptExtensions      = toNubListR $ usedExtensions bi,-      ghcOptExtensionMap    = Map.fromList . compilerExtensions $ (compiler lbi)-    }-  where-    exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt)-                | uid <- componentExeDeps clbi-                -- TODO: Ugh, localPkgDescr-                , Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] ]--toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation-toGhcOptimisation NoOptimisation      = mempty --TODO perhaps override?-toGhcOptimisation NormalOptimisation  = toFlag GhcNormalOptimisation-toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation---componentCmmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo-                      -> BuildInfo -> ComponentLocalBuildInfo-                      -> FilePath -> FilePath-                      -> GhcOptions-componentCmmGhcOptions verbosity _implInfo lbi bi clbi odir filename =-    mempty {-      -- Respect -v0, but don't crank up verbosity on GHC if-      -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!-      ghcOptVerbosity      = toFlag (min verbosity normal),-      ghcOptMode           = toFlag GhcModeCompile,-      ghcOptInputFiles     = toNubListR [filename],--      ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi-                                          ,autogenPackageModulesDir lbi-                                          ,odir]-                                          -- includes relative to the package-                                          ++ includeDirs bi-                                          -- potential includes generated by `configure'-                                          -- in the build directory-                                          ++ [buildDir lbi </> dir | dir <- includeDirs bi],-      ghcOptCppOptions     = cppOptions bi,-      ghcOptCppIncludes    = toNubListR $-                             [autogenComponentModulesDir lbi clbi </> cppHeaderName],-      ghcOptHideAllPackages= toFlag True,-      ghcOptPackageDBs     = withPackageDB lbi,-      ghcOptPackages       = toNubListR $ mkGhcOptPackages clbi,-      ghcOptOptimisation   = toGhcOptimisation (withOptimization lbi),-      ghcOptDebugInfo      = toFlag (withDebugInfo lbi),-      ghcOptExtra          = cmmOptions bi,-      ghcOptObjDir         = toFlag odir-    }----- | Strip out flags that are not supported in ghci-filterGhciFlags :: [String] -> [String]-filterGhciFlags = filter supported-  where-    supported ('-':'O':_) = False-    supported "-debug"    = False-    supported "-threaded" = False-    supported "-ticky"    = False-    supported "-eventlog" = False-    supported "-prof"     = False-    supported "-unreg"    = False-    supported _           = True--mkGHCiLibName :: UnitId -> String-mkGHCiLibName lib = getHSLibraryName lib <.> "o"--mkGHCiProfLibName :: UnitId -> String-mkGHCiProfLibName lib = getHSLibraryName lib <.> "p_o"--ghcLookupProperty :: String -> Compiler -> Bool-ghcLookupProperty prop comp =-  case Map.lookup prop (compilerProperties comp) of-    Just "YES" -> True-    _          -> False---- when using -split-objs, we need to search for object files in the--- Module_split directory for each module.-getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo-                  -> ComponentLocalBuildInfo-                  -> FilePath -> String -> Bool -> IO [FilePath]-getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs-  | splitObjs lbi && allow_split_objs = do-        let splitSuffix = "_" ++ wanted_obj_ext ++ "_split"-            dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)-                   | x <- allLibModules lib clbi ]-        objss <- traverse getDirectoryContents dirs-        let objs = [ dir </> obj-                   | (objs',dir) <- zip objss dirs, obj <- objs',-                     let obj_ext = takeExtension obj,-                     '.':wanted_obj_ext == obj_ext ]-        return objs-  | otherwise  =-        return [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext-               | x <- allLibModules lib clbi ]--mkGhcOptPackages :: ComponentLocalBuildInfo-                 -> [(OpenUnitId, ModuleRenaming)]-mkGhcOptPackages = componentIncludes--substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo-substTopDir topDir ipo- = ipo {-       IPI.importDirs        = map f (IPI.importDirs ipo),-       IPI.libraryDirs       = map f (IPI.libraryDirs ipo),-       IPI.includeDirs       = map f (IPI.includeDirs ipo),-       IPI.frameworkDirs     = map f (IPI.frameworkDirs ipo),-       IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo),-       IPI.haddockHTMLs      = map f (IPI.haddockHTMLs ipo)-   }-    where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest-          f x = x---- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let--- users know that this is the case. See ticket #335. Simply ignoring it is--- not a good idea, since then ghc and cabal are looking at different sets--- of package DBs and chaos is likely to ensue.------ An exception to this is when running cabal from within a `cabal exec`--- environment. In this case, `cabal exec` will set the--- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set--- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow--- GHC{,JS}_PACKAGE_PATH.-checkPackageDbEnvVar :: Verbosity -> String -> String -> IO ()-checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do-    mPP <- lookupEnv packagePathEnvVar-    when (isJust mPP) $ do-        mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH"-        unless (mPP == mcsPP) abort-    where-        lookupEnv :: String -> IO (Maybe String)-        lookupEnv name = (Just `fmap` getEnv name)-                         `catchIO` const (return Nothing)-        abort =-            die' verbosity $ "Use of " ++ compilerName ++ "'s environment variable "-               ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the "-               ++ "flag --package-db to specify a package database (it can be "-               ++ "used multiple times)."--        _ = callStack -- TODO: output stack when erroring--profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto-profDetailLevelFlag forLib mpl =-    case mpl of-      ProfDetailNone                -> mempty-      ProfDetailDefault | forLib    -> toFlag GhcProfAutoExported-                        | otherwise -> toFlag GhcProfAutoToplevel-      ProfDetailExportedFunctions   -> toFlag GhcProfAutoExported-      ProfDetailToplevelFunctions   -> toFlag GhcProfAutoToplevel-      ProfDetailAllFunctions        -> toFlag GhcProfAutoAll-      ProfDetailOther _             -> mempty----- -------------------------------------------------------------------------------- GHC platform and version strings---- | GHC's rendering of its host or target 'Arch' as used in its platform--- strings and certain file locations (such as user package db location).----ghcArchString :: Arch -> String-ghcArchString PPC   = "powerpc"-ghcArchString PPC64 = "powerpc64"-ghcArchString other = prettyShow other---- | GHC's rendering of its host or target 'OS' as used in its platform--- strings and certain file locations (such as user package db location).----ghcOsString :: OS -> String-ghcOsString Windows = "mingw32"-ghcOsString OSX     = "darwin"-ghcOsString Solaris = "solaris2"-ghcOsString other   = prettyShow other---- | GHC's rendering of its platform and compiler version string as used in--- certain file locations (such as user package db location).--- For example @x86_64-linux-7.10.4@----ghcPlatformAndVersionString :: Platform -> Version -> String-ghcPlatformAndVersionString (Platform arch os) version =-    intercalate "-" [ ghcArchString arch, ghcOsString os, prettyShow version ]----- -------------------------------------------------------------------------------- Constructing GHC environment files---- | The kinds of entries we can stick in a @.ghc.environment@ file.----data GhcEnvironmentFileEntry =-       GhcEnvFileComment   String     -- ^ @-- a comment@-     | GhcEnvFilePackageId UnitId     -- ^ @package-id foo-1.0-4fe301a...@-     | GhcEnvFilePackageDb PackageDB  -- ^ @global-package-db@,-                                      --   @user-package-db@ or-                                      --   @package-db blah/package.conf.d/@-     | GhcEnvFileClearPackageDbStack  -- ^ @clear-package-db@-     deriving (Eq, Ord, Show)---- | Make entries for a GHC environment file based on a 'PackageDBStack' and--- a bunch of package (unit) ids.------ If you need to do anything more complicated then either use this as a basis--- and add more entries, or just make all the entries directly.----simpleGhcEnvironmentFile :: PackageDBStack-                         -> [UnitId]-                         -> [GhcEnvironmentFileEntry]-simpleGhcEnvironmentFile packageDBs pkgids =-    GhcEnvFileClearPackageDbStack-  : map GhcEnvFilePackageDb packageDBs- ++ map GhcEnvFilePackageId pkgids---- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory.------ The 'Platform' and GHC 'Version' are needed as part of the file name.------ Returns the name of the file written.-writeGhcEnvironmentFile :: FilePath  -- ^ directory in which to put it-                        -> Platform  -- ^ the GHC target platform-                        -> Version   -- ^ the GHC version-                        -> [GhcEnvironmentFileEntry] -- ^ the content-                        -> IO FilePath-writeGhcEnvironmentFile directory platform ghcversion entries = do-    writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries-    return envfile-  where-    envfile = directory </> ghcEnvironmentFileName platform ghcversion---- | The @.ghc.environment-$arch-$os-$ver@ file name----ghcEnvironmentFileName :: Platform -> Version -> FilePath-ghcEnvironmentFileName platform ghcversion =-    ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion---- | Render a bunch of GHC environment file entries----renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry] -> String-renderGhcEnvironmentFile =-    unlines . map renderGhcEnvironmentFileEntry---- | Render an individual GHC environment file entry----renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry -> String-renderGhcEnvironmentFileEntry entry = case entry of-    GhcEnvFileComment   comment   -> format comment-      where format = intercalate "\n" . map ("--" <++>) . lines-            pref <++> ""  = pref-            pref <++> str = pref ++ " " ++ str-    GhcEnvFilePackageId pkgid     -> "package-id " ++ prettyShow pkgid-    GhcEnvFilePackageDb pkgdb     ->-      case pkgdb of-        GlobalPackageDB           -> "global-package-db"-        UserPackageDB             -> "user-package-db"-        SpecificPackageDB dbfile  -> "package-db " ++ dbfile-    GhcEnvFileClearPackageDbStack -> "clear-package-db"+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.GHC.Internal+-- Copyright   :  Isaac Jones 2003-2007+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module contains functions shared by GHC (Distribution.Simple.GHC)+-- and GHC-derived compilers.+module Distribution.Simple.GHC.Internal+  ( configureToolchain+  , getLanguages+  , getExtensions+  , targetPlatform+  , getGhcInfo+  , componentCcGhcOptions+  , componentCmmGhcOptions+  , componentCxxGhcOptions+  , componentAsmGhcOptions+  , componentJsGhcOptions+  , componentGhcOptions+  , mkGHCiLibName+  , mkGHCiProfLibName+  , filterGhciFlags+  , ghcLookupProperty+  , getHaskellObjects+  , mkGhcOptPackages+  , substTopDir+  , checkPackageDbEnvVar+  , profDetailLevelFlag++    -- * GHC platform and version strings+  , ghcArchString+  , ghcOsString+  , ghcPlatformAndVersionString++    -- * Constructing GHC environment files+  , GhcEnvironmentFileEntry (..)+  , writeGhcEnvironmentFile+  , simpleGhcEnvironmentFile+  , ghcEnvironmentFileName+  , renderGhcEnvironmentFile+  , renderGhcEnvironmentFileEntry+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Data.Bool (bool)+import qualified Data.ByteString.Lazy.Char8 as BS+import qualified Data.Map as Map+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, maybeToFlag, toFlag, pattern NoFlag)+import Distribution.Simple.GHC.ImplInfo+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Program+import Distribution.Simple.Program.GHC+import Distribution.Simple.Setup.Common (extraCompilationArtifacts)+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.GivenComponent+import Distribution.Types.LocalBuildInfo+import Distribution.Types.TargetInfo+import Distribution.Types.UnitId+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)+import System.Environment (getEnv)+import System.FilePath+  ( takeDirectory+  , takeExtension+  , takeFileName+  )+import System.IO (hClose, hPutStrLn)++targetPlatform :: [(String, String)] -> Maybe Platform+targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo++-- | Adjust the way we find and configure gcc and ld+configureToolchain+  :: GhcImplInfo+  -> ConfiguredProgram+  -> Map String String+  -> ProgramDb+  -> ProgramDb+configureToolchain _implInfo ghcProg ghcInfo =+  addKnownProgram+    gccProgram+      { programFindLocation = findProg gccProgramName extraGccPath+      , programPostConf = configureGcc+      }+    . addKnownProgram+      gppProgram+        { programFindLocation = findProg gppProgramName extraGppPath+        , programPostConf = configureGpp+        }+    . addKnownProgram+      ldProgram+        { programFindLocation = findProg ldProgramName extraLdPath+        , programPostConf = \v cp ->+            -- Call any existing configuration first and then add any new configuration+            configureLd v =<< programPostConf ldProgram v cp+        }+    . addKnownProgram+      arProgram+        { programFindLocation = findProg arProgramName extraArPath+        }+    . addKnownProgram+      stripProgram+        { programFindLocation = findProg stripProgramName extraStripPath+        }+  where+    compilerDir, base_dir, mingwBinDir :: FilePath+    compilerDir = takeDirectory (programPath ghcProg)+    base_dir = takeDirectory compilerDir+    mingwBinDir = base_dir </> "mingw" </> "bin"+    isWindows = case buildOS of Windows -> True; _ -> False+    binPrefix = ""++    maybeName :: Program -> Maybe FilePath -> String+    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++    mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]+    mkExtraPath mbPath mingwPath+      | isWindows = mbDir ++ [mingwPath]+      | otherwise = mbDir+      where+        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, b)++    findProg+      :: String+      -> [FilePath]+      -> Verbosity+      -> ProgramSearchPath+      -> IO (Maybe (FilePath, [FilePath]))+    findProg progName extraPath v searchpath =+      findProgramOnSearchPath v searchpath' progName+      where+        searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath++    -- Read tool locations from the 'ghc --info' output. Useful when+    -- cross-compiling.+    mbGccLocation = Map.lookup "C compiler command" ghcInfo+    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"+    cxxFlags = 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"++    -- 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+    -- String.+    --+    -- We first try to parse as a [String] and if this fails then tokenize the+    -- flags ourself.+    getFlags :: String -> [String]+    getFlags key =+      case Map.lookup key ghcInfo of+        Nothing -> []+        Just flags+          | (flags', "") : _ <- reads flags -> flags'+          | otherwise -> tokenizeQuotedWords flags++    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram+    configureGcc _v gccProg = do+      return+        gccProg+          { programDefaultArgs =+              programDefaultArgs gccProg+                ++ ccFlags+                ++ gccLinkerFlags+          }++    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+      return+        ldProg'+          { programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags+          }++    -- we need to find out if ld supports the -x flag+    configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram+    configureLd' verbosity ldProg = do+      ldx <- withTempFile ".c" $ \testcfile testchnd ->+        withTempFile ".o" $ \testofile testohnd -> do+          hPutStrLn testchnd "int foo() { return 0; }"+          hClose testchnd+          hClose testohnd+          runProgram+            verbosity+            ghcProg+            [ "-hide-all-packages"+            , "-c"+            , testcfile+            , "-o"+            , testofile+            ]+          withTempFile ".o" $ \testofile' testohnd' ->+            do+              hClose testohnd'+              _ <-+                getProgramOutput+                  verbosity+                  ldProg+                  ["-x", "-r", testofile, "-o", testofile']+              return True+              `catchIO` (\_ -> return False)+              `catchExit` (\_ -> return False)+      if ldx+        then return ldProg{programDefaultArgs = ["-x"]}+        else return ldProg++getLanguages+  :: Verbosity+  -> GhcImplInfo+  -> ConfiguredProgram+  -> IO [(Language, String)]+getLanguages _ implInfo _+  -- TODO: should be using --supported-languages rather than hard coding+  | supportsGHC2024 implInfo =+      return+        [ (GHC2024, "-XGHC2024")+        , (GHC2021, "-XGHC2021")+        , (Haskell2010, "-XHaskell2010")+        , (Haskell98, "-XHaskell98")+        ]+  | supportsGHC2021 implInfo =+      return+        [ (GHC2021, "-XGHC2021")+        , (Haskell2010, "-XHaskell2010")+        , (Haskell98, "-XHaskell98")+        ]+  | supportsHaskell2010 implInfo =+      return+        [ (Haskell98, "-XHaskell98")+        , (Haskell2010, "-XHaskell2010")+        ]+  | otherwise = return [(Haskell98, "")]++getGhcInfo+  :: Verbosity+  -> GhcImplInfo+  -> ConfiguredProgram+  -> IO [(String, String)]+getGhcInfo verbosity _implInfo ghcProg = do+  xs <-+    getProgramOutput+      verbosity+      (suppressOverrideArgs ghcProg)+      ["--info"]+  case reads xs of+    [(i, ss)]+      | all isSpace ss ->+          return i+    _ ->+      dieWithException verbosity CantParseGHCOutput++getExtensions+  :: Verbosity+  -> GhcImplInfo+  -> ConfiguredProgram+  -> IO [(Extension, Maybe String)]+getExtensions verbosity implInfo ghcProg = do+  str <-+    getProgramOutput+      verbosity+      (suppressOverrideArgs ghcProg)+      ["--supported-languages"]+  let extStrs =+        if reportsNoExt implInfo+          then lines str+          else -- Older GHCs only gave us either Foo or NoFoo,+          -- so we have to work out the other one ourselves++            [ extStr''+            | extStr <- lines str+            , let extStr' = case extStr of+                    'N' : 'o' : xs -> xs+                    _ -> "No" ++ extStr+            , extStr'' <- [extStr, extStr']+            ]+  let extensions0 =+        [ (ext, Just $ "-X" ++ prettyShow ext)+        | Just ext <- map simpleParsec extStrs+        ]+      extensions1 =+        if alwaysNondecIndent implInfo+          then -- ghc-7.2 split NondecreasingIndentation off+          -- into a proper extension. Before that it+          -- was always on.+          -- Since it was not a proper extension, it could+          -- not be turned off, hence we omit a+          -- DisableExtension entry here.++            (EnableExtension NondecreasingIndentation, Nothing)+              : extensions0+          else extensions0+  return extensions1++includePaths+  :: LocalBuildInfo+  -> BuildInfo+  -> ComponentLocalBuildInfo+  -> SymbolicPath Pkg p+  -> NubListR (SymbolicPath Pkg (Dir Include))+includePaths lbi bi clbi odir =+  toNubListR $+    [ coerceSymbolicPath $ autogenComponentModulesDir lbi clbi+    , coerceSymbolicPath $ autogenPackageModulesDir lbi+    , coerceSymbolicPath odir+    ]+      -- includes relative to the package+      ++ includeDirs bi+      -- potential includes generated by `configure'+      -- in the build directory+      ++ [ buildDir lbi </> dir+         | dir <- mapMaybe (symbolicPathRelative_maybe . unsafeCoerceSymbolicPath) $ includeDirs bi+         ]++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+    }++componentCxxGhcOptions+  :: Verbosity+  -> 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+    }++componentAsmGhcOptions+  :: Verbosity+  -> 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)+    , 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+    , ghcOptExtra = hcOptions GHC bi+    }++componentJsGhcOptions+  :: Verbosity+  -> LocalBuildInfo+  -> BuildInfo+  -> ComponentLocalBuildInfo+  -> SymbolicPath Pkg (Dir Artifacts)+  -> SymbolicPath Pkg File+  -> 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]+    , ghcOptJSppOptions = jsppOptions bi+    , ghcOptCppIncludePath = includePaths lbi bi clbi odir+    , ghcOptHideAllPackages = toFlag True+    , ghcOptPackageDBs = withPackageDB lbi+    , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi+    , ghcOptObjDir = toFlag odir+    , ghcOptExtra = hcOptions GHC bi+    }++componentGhcOptions+  :: Verbosity+  -> LocalBuildInfo+  -> BuildInfo+  -> ComponentLocalBuildInfo+  -> SymbolicPath Pkg (Dir build)+  -> GhcOptions+componentGhcOptions verbosity lbi bi clbi odir =+  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)+        , ghcOptCabal = toFlag True+        , ghcOptThisUnitId = case clbi of+            LibComponentLocalBuildInfo{componentCompatPackageKey = pk} ->+              toFlag pk+            _ | not (unitIdForExes implInfo) -> mempty+            ExeComponentLocalBuildInfo{componentUnitId = uid} ->+              toFlag (unUnitId uid)+            TestComponentLocalBuildInfo{componentUnitId = uid} ->+              toFlag (unUnitId uid)+            BenchComponentLocalBuildInfo{componentUnitId = uid} ->+              toFlag (unUnitId uid)+            FLibComponentLocalBuildInfo{componentUnitId = uid} ->+              toFlag (unUnitId uid)+        , ghcOptThisComponentId = case clbi of+            LibComponentLocalBuildInfo+              { componentComponentId = cid+              , componentInstantiatedWith = insts+              } ->+                if null insts+                  then mempty+                  else toFlag cid+            _ -> mempty+        , ghcOptInstantiatedWith = case clbi of+            LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->+              insts+            _ -> []+        , ghcOptNoCode = toFlag $ componentIsIndefinite clbi+        , ghcOptHideAllPackages = toFlag True+        , ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo+        , ghcOptPackageDBs = withPackageDB lbi+        , ghcOptPackages = toNubListR $ mkGhcOptPackages mempty clbi+        , ghcOptSplitSections = toFlag (splitSections lbi)+        , ghcOptSplitObjs = toFlag (splitObjs lbi)+        , ghcOptSourcePathClear = toFlag True+        , ghcOptSourcePath =+            toNubListR $+              (hsSourceDirs bi)+                ++ [coerceSymbolicPath odir]+                ++ [autogenComponentModulesDir lbi clbi]+                ++ [autogenPackageModulesDir lbi]+        , ghcOptCppIncludePath = includePaths lbi bi clbi odir+        , ghcOptCppOptions = cppOptions bi+        , ghcOptJSppOptions = jsppOptions bi+        , ghcOptCppIncludes =+            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)+        }+  where+    exe_paths =+      [ componentBuildDir lbi (targetCLBI exe_tgt)+      | uid <- componentExeDeps clbi+      , -- TODO: Ugh, localPkgDescr+      Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid]+      ]++toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation+toGhcOptimisation NoOptimisation = mempty -- TODO perhaps override?+toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation+toGhcOptimisation 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 = hcOptions GHC bi <> cmmOptions bi+    , ghcOptObjDir = toFlag odir+    }++-- | Strip out flags that are not supported in ghci+filterGhciFlags :: [String] -> [String]+filterGhciFlags = filter supported+  where+    supported ('-' : 'O' : _) = False+    supported "-debug" = False+    supported "-threaded" = False+    supported "-ticky" = False+    supported "-eventlog" = False+    supported "-prof" = False+    supported "-unreg" = False+    supported _ = True++mkGHCiLibName :: UnitId -> String+mkGHCiLibName lib = getHSLibraryName lib <.> "o"++mkGHCiProfLibName :: UnitId -> String+mkGHCiProfLibName lib = getHSLibraryName lib <.> "p_o"++ghcLookupProperty :: String -> Compiler -> Bool+ghcLookupProperty prop comp =+  case Map.lookup prop (compilerProperties comp) of+    Just "YES" -> True+    _ -> False++-- when using -split-objs, we need to search for object files in the+-- Module_split directory for each module.+getHaskellObjects+  :: GhcImplInfo+  -> Library+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> SymbolicPath Pkg (Dir Artifacts)+  -> String+  -> Bool+  -> IO [SymbolicPath Pkg File]+getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs+  | splitObjs lbi && allow_split_objs = do+      let splitSuffix = "_" ++ wanted_obj_ext ++ "_split"+          dirs =+            [ pref </> makeRelativePathEx (ModuleName.toFilePath x ++ splitSuffix)+            | x <- allLibModules lib clbi+            ]+      objss <- traverse (getDirectoryContents . i) dirs+      let objs =+            [ dir </> makeRelativePathEx obj+            | (objs', dir) <- zip objss dirs+            , obj <- objs'+            , let obj_ext = takeExtension obj+            , '.' : wanted_obj_ext == obj_ext+            ]+      return objs+  | otherwise =+      return+        [ pref </> makeRelativePathEx (ModuleName.toFilePath x <.> wanted_obj_ext)+        | x <- allLibModules lib clbi+        ]+  where+    i = interpretSymbolicPathLBI lbi++-- | Create the required packaged arguments, but filtering out package arguments which+-- aren't yet built, but promised. This filtering is used when compiling C/Cxx/Asm files,+-- and is a hack to avoid passing bogus `-package` arguments to GHC. The assumption being that+-- in 99% of cases we will include the right `-package` so that the C file finds the right headers.+mkGhcOptPackages+  :: Map (PackageName, ComponentName) PromisedComponent+  -> ComponentLocalBuildInfo+  -> [(OpenUnitId, ModuleRenaming)]+mkGhcOptPackages promisedPkgsMap clbi =+  [ i | i@(uid, _) <- componentIncludes clbi, abstractUnitId uid `Set.notMember` promised_cids+  ]+  where+    -- Promised deps are going to be simple UnitIds+    promised_cids = Set.fromList (map (newSimpleUnitId . promisedComponentId) (Map.elems promisedPkgsMap))++substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo+substTopDir topDir ipo =+  ipo+    { IPI.importDirs = map f (IPI.importDirs ipo)+    , IPI.libraryDirs = map f (IPI.libraryDirs ipo)+    , IPI.libraryDirsStatic = map f (IPI.libraryDirsStatic ipo)+    , IPI.includeDirs = map f (IPI.includeDirs ipo)+    , IPI.frameworkDirs = map f (IPI.frameworkDirs ipo)+    , IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo)+    , IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo)+    }+  where+    f ('$' : 't' : 'o' : 'p' : 'd' : 'i' : 'r' : rest) = topDir ++ rest+    f x = x++-- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let+-- users know that this is the case. See ticket #335. Simply ignoring it is+-- not a good idea, since then ghc and cabal are looking at different sets+-- of package DBs and chaos is likely to ensue.+--+-- An exception to this is when running cabal from within a `cabal exec`+-- environment. In this case, `cabal exec` will set the+-- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set+-- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow+-- GHC{,JS}_PACKAGE_PATH.+checkPackageDbEnvVar :: Verbosity -> String -> String -> IO ()+checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do+  mPP <- lookupEnv packagePathEnvVar+  when (isJust mPP) $ do+    mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH"+    unless (mPP == mcsPP) abort+  where+    lookupEnv :: String -> IO (Maybe String)+    lookupEnv name =+      (Just `fmap` getEnv name)+        `catchIO` const (return Nothing)+    abort =+      dieWithException verbosity $ IncompatibleWithCabal compilerName packagePathEnvVar+    _ = callStack -- TODO: output stack when erroring++profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto+profDetailLevelFlag forLib mpl =+  case mpl of+    ProfDetailNone -> mempty+    ProfDetailDefault+      | forLib -> toFlag GhcProfAutoExported+      | otherwise -> toFlag GhcProfAutoToplevel+    ProfDetailExportedFunctions -> toFlag GhcProfAutoExported+    ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel+    ProfDetailAllFunctions -> toFlag GhcProfAutoAll+    ProfDetailTopLate -> toFlag GhcProfLate+    ProfDetailOther _ -> mempty++-- -----------------------------------------------------------------------------+-- GHC platform and version strings++-- | GHC's rendering of its host or target 'Arch' as used in its platform+-- strings and certain file locations (such as user package db location).+ghcArchString :: Arch -> String+ghcArchString PPC = "powerpc"+ghcArchString PPC64 = "powerpc64"+ghcArchString PPC64LE = "powerpc64le"+ghcArchString other = prettyShow other++-- | GHC's rendering of its host or target 'OS' as used in its platform+-- strings and certain file locations (such as user package db location).+ghcOsString :: OS -> String+ghcOsString Windows = "mingw32"+ghcOsString OSX = "darwin"+ghcOsString Solaris = "solaris2"+ghcOsString Hurd = "gnu"+ghcOsString other = prettyShow other++-- | GHC's rendering of its platform and compiler version string as used in+-- certain file locations (such as user package db location).+-- For example @x86_64-linux-7.10.4@+ghcPlatformAndVersionString :: Platform -> Version -> String+ghcPlatformAndVersionString (Platform arch os) version =+  intercalate "-" [ghcArchString arch, ghcOsString os, prettyShow version]++-- -----------------------------------------------------------------------------+-- Constructing GHC environment files++-- | The kinds of entries we can stick in a @.ghc.environment@ file.+data GhcEnvironmentFileEntry fp+  = -- | @-- a comment@+    GhcEnvFileComment String+  | -- | @package-id foo-1.0-4fe301a...@+    GhcEnvFilePackageId UnitId+  | -- | @global-package-db@,+    --   @user-package-db@ or+    --   @package-db blah/package.conf.d/@+    GhcEnvFilePackageDb (PackageDBX fp)+  | -- | @clear-package-db@+    GhcEnvFileClearPackageDbStack+  deriving (Eq, Ord, Show)++-- | Make entries for a GHC environment file based on a 'PackageDBStack' and+-- a bunch of package (unit) ids.+--+-- If you need to do anything more complicated then either use this as a basis+-- and add more entries, or just make all the entries directly.+simpleGhcEnvironmentFile+  :: PackageDBStackX fp+  -> [UnitId]+  -> [GhcEnvironmentFileEntry fp]+simpleGhcEnvironmentFile packageDBs pkgids =+  GhcEnvFileClearPackageDbStack+    : map GhcEnvFilePackageDb packageDBs+    ++ map GhcEnvFilePackageId pkgids++-- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory.+--+-- The 'Platform' and GHC 'Version' are needed as part of the file name.+--+-- Returns the name of the file written.+writeGhcEnvironmentFile+  :: FilePath+  -- ^ directory in which to put it+  -> Platform+  -- ^ the GHC target platform+  -> Version+  -- ^ the GHC version+  -> [GhcEnvironmentFileEntry FilePath]+  -- ^ the content+  -> IO FilePath+writeGhcEnvironmentFile directory platform ghcversion entries = do+  writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries+  return envfile+  where+    envfile = directory </> ghcEnvironmentFileName platform ghcversion++-- | The @.ghc.environment-$arch-$os-$ver@ file name+ghcEnvironmentFileName :: Platform -> Version -> FilePath+ghcEnvironmentFileName platform ghcversion =+  ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion++-- | Render a bunch of GHC environment file entries+renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry FilePath] -> String+renderGhcEnvironmentFile =+  unlines . map renderGhcEnvironmentFileEntry++-- | Render an individual GHC environment file entry+renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry FilePath -> String+renderGhcEnvironmentFileEntry entry = case entry of+  GhcEnvFileComment comment -> format comment+    where+      format = intercalate "\n" . map ("--" <++>) . lines+      pref <++> "" = pref+      pref <++> str = pref ++ " " ++ str+  GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid+  GhcEnvFilePackageDb pkgdb ->+    case pkgdb of+      GlobalPackageDB -> "global-package-db"+      UserPackageDB -> "user-package-db"+      SpecificPackageDB dbfile -> "package-db " ++ dbfile+  GhcEnvFileClearPackageDbStack -> "clear-package-db"
src/Distribution/Simple/GHCJS.hs view
@@ -1,1826 +1,2116 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE CPP #-}--module Distribution.Simple.GHCJS (-        getGhcInfo,-        configure,-        getInstalledPackages,-        getInstalledPackagesMonitorFiles,-        getPackageDBContents,-        buildLib, buildFLib, buildExe,-        replLib, replFLib, replExe,-        startInterpreter,-        installLib, installFLib, installExe,-        libAbiHash,-        hcPkgInfo,-        registerPackage,-        componentGhcOptions,-        componentCcGhcOptions,-        getLibDir,-        isDynamic,-        getGlobalPackageDB,-        pkgRoot,-        runCmd,-        -- * Constructing and deconstructing GHC environment files-        Internal.GhcEnvironmentFileEntry(..),-        Internal.simpleGhcEnvironmentFile,-        Internal.renderGhcEnvironmentFile,-        Internal.writeGhcEnvironmentFile,-        Internal.ghcPlatformAndVersionString,-        readGhcEnvironmentFile,-        parseGhcEnvironmentFile,-        ParseErrorExc(..),-        -- * Version-specific implementation quirks-        getImplInfo,-        GhcImplInfo(..)- ) where--import Prelude ()-import Distribution.Compat.Prelude--import qualified Distribution.Simple.GHC.Internal as Internal-import Distribution.Simple.GHC.ImplInfo-import Distribution.Simple.GHC.EnvironmentParser-import Distribution.PackageDescription.Utils (cabalBug)-import Distribution.PackageDescription as PD-import Distribution.InstalledPackageInfo (InstalledPackageInfo)-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.LocalBuildInfo-import Distribution.Types.ComponentLocalBuildInfo-import qualified Distribution.Simple.Hpc as Hpc-import Distribution.Simple.BuildPaths-import Distribution.Simple.Utils-import Distribution.Package-import qualified Distribution.ModuleName as ModuleName-import Distribution.ModuleName (ModuleName)-import Distribution.Simple.Program-import qualified Distribution.Simple.Program.HcPkg as HcPkg-import qualified Distribution.Simple.Program.Strip as Strip-import Distribution.Simple.Program.GHC-import Distribution.Simple.Setup-import qualified Distribution.Simple.Setup as Cabal-import Distribution.Simple.Compiler-import Distribution.CabalSpecVersion-import Distribution.Version-import Distribution.System-import Distribution.Verbosity-import Distribution.Pretty-import Distribution.Utils.NubList-import Distribution.Utils.Path--import Control.Monad (msum)-import Data.Char (isLower)-import qualified Data.Map as Map-import System.Directory-         ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing-         , canonicalizePath, removeFile, renameFile )-import System.FilePath          ( (</>), (<.>), takeExtension-                                , takeDirectory, replaceExtension-                                ,isRelative )-import qualified System.Info---- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramDb-          -> IO (Compiler, Maybe Platform, ProgramDb)-configure verbosity hcPath hcPkgPath conf0 = do--  (ghcjsProg, ghcjsVersion, progdb1) <--    requireProgramVersion verbosity ghcjsProgram-      (orLaterVersion (mkVersion [0,1]))-      (userMaybeSpecifyPath "ghcjs" hcPath conf0)--  Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg)-  unless (ghcjsGhcVersion < mkVersion [8,8]) $-    warn verbosity $-         "Unknown/unsupported 'ghc' version detected "-      ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 8.8): "-      ++ programPath ghcjsProg ++ " is based on GHC version " ++-      prettyShow ghcjsGhcVersion--  let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion--  -- 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:-  (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <--    requireProgramVersion verbosity ghcjsPkgProgram {-      programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg-    }-    anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1)--  Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion-                                  verbosity (programPath ghcjsPkgProg)--  when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die' verbosity $-       "Version mismatch between ghcjs and ghcjs-pkg: "-    ++ programPath ghcjsProg ++ " is version " ++ prettyShow ghcjsVersion ++ " "-    ++ programPath ghcjsPkgProg ++ " is version " ++ prettyShow ghcjsPkgGhcjsVersion--  when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die' verbosity $-       "Version mismatch between ghcjs and ghcjs-pkg: "-    ++ programPath ghcjsProg-    ++ " was built with GHC version " ++ prettyShow ghcjsGhcVersion ++ " "-    ++ programPath ghcjsPkgProg-    ++ " was built with GHC version " ++ prettyShow ghcjsPkgVersion---  -- Likewise we try to find the matching hsc2hs and haddock programs.-  let hsc2hsProgram' = hsc2hsProgram {-                           programFindLocation =-                             guessHsc2hsFromGhcjsPath ghcjsProg-                       }-      haddockProgram' = haddockProgram {-                           programFindLocation =-                             guessHaddockFromGhcjsPath ghcjsProg-                       }-      hpcProgram' = hpcProgram {-                        programFindLocation = guessHpcFromGhcjsPath ghcjsProg-                    }-                    {--      runghcProgram' = runghcProgram {-                        programFindLocation = guessRunghcFromGhcjsPath ghcjsProg-                    } -}-      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--  let comp = Compiler {-        compilerId         = CompilerId GHCJS ghcjsVersion,-        compilerAbiTag     = AbiTag $-          "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion),-        compilerCompat     = [CompilerId GHC ghcjsGhcVersion],-        compilerLanguages  = languages,-        compilerExtensions = extensions,-        compilerProperties = ghcInfoMap-      }-      compPlatform = Internal.targetPlatform ghcjsInfo-  return (comp, compPlatform, progdb3)--guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity-                           -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath]))-guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram--guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity-                         -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath]))-guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram--guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity-                          -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath]))-guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram--guessHpcFromGhcjsPath :: ConfiguredProgram-                       -> Verbosity -> ProgramSearchPath-                       -> IO (Maybe (FilePath, [FilePath]))-guessHpcFromGhcjsPath = guessToolFromGhcjsPath hpcProgram---guessToolFromGhcjsPath :: Program -> ConfiguredProgram-                     -> Verbosity -> ProgramSearchPath-                     -> IO (Maybe (FilePath, [FilePath]))-guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath-  = do let toolname          = programName tool-           given_path        = programPath ghcjsProg-           given_dir         = takeDirectory given_path-       real_path <- canonicalizePath given_path-       let real_dir           = takeDirectory real_path-           versionSuffix path = takeVersionSuffix (dropExeExtension path)-           given_suf = versionSuffix given_path-           real_suf  = versionSuffix real_path-           guessNormal         dir = dir </> toolname <.> exeExtension buildPlatform-           guessGhcjs          dir = dir </> (toolname ++ "-ghcjs")-                                         <.> exeExtension buildPlatform-           guessGhcjsVersioned dir suf = dir </> (toolname ++ "-ghcjs" ++ suf)-                                             <.> exeExtension buildPlatform-           guessVersioned      dir suf = dir </> (toolname ++ suf)-                                             <.> exeExtension buildPlatform-           mkGuesses dir suf | null suf  = [guessGhcjs dir, guessNormal dir]-                             | otherwise = [guessGhcjsVersioned dir suf,-                                            guessVersioned dir suf,-                                            guessGhcjs dir,-                                            guessNormal dir]-           guesses = mkGuesses given_dir given_suf ++-                            if real_path == given_path-                                then []-                                else mkGuesses real_dir real_suf-       info verbosity $ "looking for tool " ++ toolname-         ++ " near compiler in " ++ given_dir-       debug verbosity $ "candidate locations: " ++ show guesses-       exists <- traverse doesFileExist guesses-       case [ file | (file, True) <- zip guesses exists ] of-                   -- If we can't find it near ghc, fall back to the usual-                   -- method.-         []     -> programFindLocation tool verbosity searchpath-         (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp-                      let lookedAt = map fst-                                   . takeWhile (\(_file, exist) -> not exist)-                                   $ zip guesses exists-                      return (Just (fp, lookedAt))--  where takeVersionSuffix :: FilePath -> String-        takeVersionSuffix = takeWhileEndLE isSuffixChar--        isSuffixChar :: Char -> Bool-        isSuffixChar c = isDigit c || c == '.' || c == '-'--getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]-getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg-  where-    version = fromMaybe (error "GHCJS.getGhcInfo: no version") $ programVersion ghcjsProg-    implInfo = ghcVersionImplInfo version---- | Given a single package DB, return all installed packages.-getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb-                     -> IO InstalledPackageIndex-getPackageDBContents verbosity packagedb progdb = do-  pkgss <- getInstalledPackages' verbosity [packagedb] progdb-  toPackageIndex verbosity pkgss progdb---- | Given a package DB stack, return all installed packages.-getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb-                     -> IO InstalledPackageIndex-getInstalledPackages verbosity packagedbs progdb = do-  checkPackageDbEnvVar verbosity-  checkPackageDbStack verbosity packagedbs-  pkgss <- getInstalledPackages' verbosity packagedbs progdb-  index <- toPackageIndex verbosity pkgss progdb-  return $! index--toPackageIndex :: Verbosity-               -> [(PackageDB, [InstalledPackageInfo])]-               -> ProgramDb-               -> IO InstalledPackageIndex-toPackageIndex verbosity pkgss progdb = do-  -- On Windows, various fields have $topdir/foo rather than full-  -- paths. We need to substitute the right value in so that when-  -- we, for example, call gcc, we have proper paths to give it.-  topDir <- getLibDir' verbosity ghcjsProg-  let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)-                | (_, pkgs) <- pkgss ]-  return $! (mconcat indices)--  where-    ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb--getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath-getLibDir verbosity lbi =-    dropWhileEndLE isSpace `fmap`-     getDbProgramOutput verbosity ghcjsProgram-     (withPrograms lbi) ["--print-libdir"]--getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath-getLibDir' verbosity ghcjsProg =-    dropWhileEndLE isSpace `fmap`-     getProgramOutput verbosity ghcjsProg ["--print-libdir"]----- | Return the 'FilePath' to the global GHC package database.-getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath-getGlobalPackageDB verbosity ghcProg =-    dropWhileEndLE isSpace `fmap`-     getProgramOutput verbosity ghcProg ["--print-global-package-db"]---- | Return the 'FilePath' to the per-user GHC package database.-getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath-getUserPackageDB _verbosity ghcjsProg platform = do-    -- It's rather annoying that we have to reconstruct this, because ghc-    -- hides this information from us otherwise. But for certain use cases-    -- like change monitoring it really can't remain hidden.-    appdir <- getAppUserDataDirectory "ghcjs"-    return (appdir </> platformAndVersion </> packageConfFileName)-  where-    platformAndVersion = Internal.ghcPlatformAndVersionString-                           platform ghcjsVersion-    packageConfFileName = "package.conf.d"-    ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg--checkPackageDbEnvVar :: Verbosity -> IO ()-checkPackageDbEnvVar verbosity =-    Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH"--checkPackageDbStack :: Verbosity -> PackageDBStack -> IO ()-checkPackageDbStack _ (GlobalPackageDB:rest)-  | GlobalPackageDB `notElem` rest = return ()-checkPackageDbStack verbosity rest-  | GlobalPackageDB `notElem` rest =-  die' verbosity $ "With current ghc versions the global package db is always used "-     ++ "and must be listed first. This ghc limitation may be lifted in "-     ++ "future, see https://gitlab.haskell.org/ghc/ghc/-/issues/5977"-checkPackageDbStack verbosity _ =-  die' verbosity $ "If the global package db is specified, it must be "-     ++ "specified first and cannot be specified multiple times"--getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb-                      -> IO [(PackageDB, [InstalledPackageInfo])]-getInstalledPackages' verbosity packagedbs progdb =-  sequenceA-    [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb-         return (packagedb, pkgs)-    | packagedb <- packagedbs ]---- | Get the packages from specific PackageDBs, not cumulative.----getInstalledPackagesMonitorFiles :: Verbosity -> Platform-                                 -> ProgramDb-                                 -> [PackageDB]-                                 -> IO [FilePath]-getInstalledPackagesMonitorFiles verbosity platform progdb =-    traverse getPackageDBPath-  where-    getPackageDBPath :: PackageDB -> IO FilePath-    getPackageDBPath GlobalPackageDB =-      selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg--    getPackageDBPath UserPackageDB =-      selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform--    getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path--    -- GHC has old style file dbs, and new style directory dbs.-    -- Note that for dir style dbs, we only need to monitor the cache file, not-    -- the whole directory. The ghc program itself only reads the cache file-    -- so it's safe to only monitor this one file.-    selectMonitorFile path = do-      isFileStyle <- doesFileExist path-      if isFileStyle then return path-                     else return (path </> "package.cache")--    ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb---toJSLibName :: String -> String-toJSLibName lib-  | takeExtension lib `elem` [".dll",".dylib",".so"]-                              = replaceExtension lib "js_so"-  | takeExtension lib == ".a" = replaceExtension lib "js_a"-  | otherwise                 = lib <.> "js_a"---- -------------------------------------------------------------------------------- Building a library--buildLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription-         -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo-         -> IO ()-buildLib = buildOrReplLib Nothing--replLib :: [String]                -> Verbosity-        -> Cabal.Flag (Maybe Int)  -> PackageDescription-        -> LocalBuildInfo          -> Library-        -> ComponentLocalBuildInfo -> IO ()-replLib = buildOrReplLib . Just--buildOrReplLib :: Maybe [String] -> Verbosity-               -> Cabal.Flag (Maybe Int) -> PackageDescription-               -> LocalBuildInfo -> Library-               -> ComponentLocalBuildInfo -> IO ()-buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do-  let uid = componentUnitId clbi-      libTargetDir = componentBuildDir lbi clbi-      whenVanillaLib forceVanilla =-        when (forceVanilla || withVanillaLib lbi)-      whenProfLib = when (withProfLib lbi)-      whenSharedLib forceShared =-        when (forceShared || withSharedLib lbi)-      whenStaticLib forceStatic =-        when (forceStatic || withStaticLib lbi)-      -- whenGHCiLib = when (withGHCiLib lbi)-      forRepl = maybe False (const True) mReplFlags-      -- ifReplLib = when forRepl-      comp = compiler lbi-      implInfo  = getImplInfo comp-      platform@(Platform _hostArch _hostOS) = hostPlatform lbi-      has_code = not (componentIsIndefinite clbi)--  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)-  let runGhcjsProg = runGHC verbosity ghcjsProg comp platform--  let libBi = libBuildInfo lib--  -- fixme flags shouldn't depend on ghcjs being dynamic or not-  let isGhcjsDynamic        = isDynamic comp-      dynamicTooSupported = supportsDynamicToo comp-      doingTH = usesTemplateHaskellOrQQ libBi-      forceVanillaLib = doingTH && not isGhcjsDynamic-      forceSharedLib  = doingTH &&     isGhcjsDynamic-      -- TH always needs default libs, even when building for profiling--  -- Determine if program coverage should be enabled and if so, what-  -- '-hpcdir' should be.-  let isCoverageEnabled = libCoverage lbi-      -- TODO: Historically HPC files have been put into a directory which-      -- has the package name.  I'm going to avoid changing this for-      -- now, but it would probably be better for this to be the-      -- component ID instead...-      pkg_name = prettyShow (PD.package pkg_descr)-      distPref = fromFlag $ configDistPref $ configFlags lbi-      hpcdir way-        | forRepl = mempty  -- HPC is not supported in ghci-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name-        | otherwise = mempty--  createDirectoryIfMissingVerbose verbosity True libTargetDir-  -- TODO: do we need to put hs-boot files into place for mutually recursive-  -- modules?-  let cLikeFiles  = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi)-      jsSrcs      = jsSources libBi-      cObjs       = map (`replaceExtension` objExtension) cLikeFiles-      baseOpts    = componentGhcOptions verbosity lbi libBi clbi libTargetDir-      linkJsLibOpts = mempty {-                        ghcOptExtra =-                          [ "-link-js-lib"     , getHSLibraryName uid-                          , "-js-lib-outputdir", libTargetDir ] ++-                          jsSrcs-                      }-      vanillaOptsNoJsLib = baseOpts `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeMake,-                      ghcOptNumJobs      = numJobs,-                      ghcOptInputModules = toNubListR $ allLibModules lib clbi,-                      ghcOptHPCDir       = hpcdir Hpc.Vanilla-                    }-      vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts--      profOpts    = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty {-                      ghcOptProfilingMode = toFlag True,-                      ghcOptProfilingAuto = Internal.profDetailLevelFlag True-                                              (withProfLibDetail lbi),-                    --  ghcOptHiSuffix      = toFlag "p_hi",-                    --  ghcOptObjSuffix     = toFlag "p_o",-                      ghcOptExtra         = hcProfOptions GHC libBi,-                      ghcOptHPCDir        = hpcdir Hpc.Prof-                    }--      sharedOpts  = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty {-                      ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                      ghcOptFPic        = toFlag True,-                    --  ghcOptHiSuffix    = toFlag "dyn_hi",-                    --  ghcOptObjSuffix   = toFlag "dyn_o",-                      ghcOptExtra       = hcSharedOptions GHC libBi,-                      ghcOptHPCDir      = hpcdir Hpc.Dyn-                    }--      vanillaSharedOpts = vanillaOpts `mappend` mempty {-                      ghcOptDynLinkMode  = toFlag GhcStaticAndDynamic,-                      ghcOptDynHiSuffix  = toFlag "js_dyn_hi",-                      ghcOptDynObjSuffix = toFlag "js_dyn_o",-                      ghcOptHPCDir       = hpcdir Hpc.Dyn-                    }--  unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $-    do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts)-           shared  = whenSharedLib  forceSharedLib  (runGhcjsProg sharedOpts)-           useDynToo = dynamicTooSupported &&-                       (forceVanillaLib || withVanillaLib lbi) &&-                       (forceSharedLib  || withSharedLib  lbi) &&-                       null (hcSharedOptions GHC libBi)-       if not has_code-        then vanilla-        else-         if useDynToo-          then do-              runGhcjsProg vanillaSharedOpts-              case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of-                (Cabal.Flag dynDir, Cabal.Flag vanillaDir) ->-                    -- When the vanilla and shared library builds are done-                    -- in one pass, only one set of HPC module interfaces-                    -- are generated. This set should suffice for both-                    -- static and dynamically linked executables. We copy-                    -- the modules interfaces so they are available under-                    -- both ways.-                    copyDirectoryRecursive verbosity dynDir vanillaDir-                _ -> return ()-          else if isGhcjsDynamic-            then do shared;  vanilla-            else do vanilla; shared-       whenProfLib (runGhcjsProg profOpts)--  -- Build any C++ sources separately.-  {--  unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do-    info verbosity "Building C++ Sources..."-    sequence_-      [ do let baseCxxOpts    = Internal.componentCxxGhcOptions verbosity implInfo-                                lbi libBi clbi libTargetDir filename-               vanillaCxxOpts = if isGhcjsDynamic-                                then baseCxxOpts { ghcOptFPic = toFlag True }-                                else baseCxxOpts-               profCxxOpts    = vanillaCxxOpts `mappend` mempty {-                                  ghcOptProfilingMode = toFlag True,-                                  ghcOptObjSuffix     = toFlag "p_o"-                                }-               sharedCxxOpts  = vanillaCxxOpts `mappend` mempty {-                                 ghcOptFPic        = toFlag True,-                                 ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                                 ghcOptObjSuffix   = toFlag "dyn_o"-                               }-               odir           = fromFlag (ghcOptObjDir vanillaCxxOpts)-           createDirectoryIfMissingVerbose verbosity True odir-           let runGhcProgIfNeeded cxxOpts = do-                 needsRecomp <- checkNeedsRecompilation filename cxxOpts-                 when needsRecomp $ runGhcjsProg cxxOpts-           runGhcProgIfNeeded vanillaCxxOpts-           unless forRepl $-             whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts)-           unless forRepl $ whenProfLib   (runGhcProgIfNeeded   profCxxOpts)-      | filename <- cxxSources libBi]--  ifReplLib $ do-    when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules"-    ifReplLib (runGhcjsProg replOpts)--}-  -- build any C sources-  -- TODO: Add support for S and CMM files.-  {--  unless (not has_code || null (cSources libBi) || not nativeToo) $ do-    info verbosity "Building C Sources..."-    sequence_-      [ do let baseCcOpts    = Internal.componentCcGhcOptions verbosity implInfo-                               lbi libBi clbi libTargetDir filename-               vanillaCcOpts = if isGhcjsDynamic-                               -- Dynamic GHC requires C sources to be built-                               -- with -fPIC for REPL to work. See #2207.-                               then baseCcOpts { ghcOptFPic = toFlag True }-                               else baseCcOpts-               profCcOpts    = vanillaCcOpts `mappend` mempty {-                                 ghcOptProfilingMode = toFlag True,-                                 ghcOptObjSuffix     = toFlag "p_o"-                               }-               sharedCcOpts  = vanillaCcOpts `mappend` mempty {-                                 ghcOptFPic        = toFlag True,-                                 ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                                 ghcOptObjSuffix   = toFlag "dyn_o"-                               }-               odir          = fromFlag (ghcOptObjDir vanillaCcOpts)-           createDirectoryIfMissingVerbose verbosity True odir-           let runGhcProgIfNeeded ccOpts = do-                 needsRecomp <- checkNeedsRecompilation filename ccOpts-                 when needsRecomp $ runGhcjsProg ccOpts-           runGhcProgIfNeeded vanillaCcOpts-           unless forRepl $-             whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts)-           unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts)-      | filename <- cSources libBi]--}-  -- TODO: problem here is we need the .c files built first, so we can load them-  -- with ghci, but .c files can depend on .h files generated by ghc by ffi-  -- exports.--  -- link:--  when has_code . when False {- fixme nativeToo -} . unless forRepl $ do-    info verbosity "Linking..."-    let cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))-                      (cSources libBi ++ cxxSources libBi)-        compiler_id = compilerId (compiler lbi)-        sharedLibFilePath = libTargetDir </> mkSharedLibName (hostPlatform lbi) compiler_id uid-        staticLibFilePath = libTargetDir </> mkStaticLibName (hostPlatform lbi) compiler_id uid--    let stubObjs = []-        stubSharedObjs = []--{--    stubObjs <- catMaybes <$> sequenceA-      [ findFileWithExtension [objExtension] [libTargetDir]-          (ModuleName.toFilePath x ++"_stub")-      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files-      , x <- allLibModules lib clbi ]-    stubProfObjs <- catMaybes <$> sequenceA-      [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]-          (ModuleName.toFilePath x ++"_stub")-      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files-      , x <- allLibModules lib clbi ]-    stubSharedObjs <- catMaybes <$> sequenceA-      [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]-          (ModuleName.toFilePath x ++"_stub")-      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files-      , x <- allLibModules lib clbi ]--}-    hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi-               libTargetDir objExtension True-    hSharedObjs <--      if withSharedLib lbi-              then Internal.getHaskellObjects implInfo lib lbi clbi-                      libTargetDir ("dyn_" ++ objExtension) False-              else return []--    unless (null hObjs && null cObjs && null stubObjs) $ do-      rpaths <- getRPaths lbi clbi--      let staticObjectFiles =-                 hObjs-              ++ map (libTargetDir </>) cObjs-              ++ stubObjs-          dynamicObjectFiles =-                 hSharedObjs-              ++ map (libTargetDir </>) cSharedObjs-              ++ stubSharedObjs-          -- After the relocation lib is created we invoke ghc -shared-          -- with the dependencies spelled out as -package arguments-          -- and ghc invokes the linker with the proper library paths-          ghcSharedLinkArgs =-              mempty {-                ghcOptShared             = toFlag True,-                ghcOptDynLinkMode        = toFlag GhcDynamicOnly,-                ghcOptInputFiles         = toNubListR dynamicObjectFiles,-                ghcOptOutputFile         = toFlag sharedLibFilePath,-                ghcOptExtra              = hcSharedOptions GHC libBi,-                -- For dynamic libs, Mac OS/X needs to know the install location-                -- at build time. This only applies to GHC < 7.8 - see the-                -- discussion in #1660.-            {--                ghcOptDylibName          = if hostOS == OSX-                                              && ghcVersion < mkVersion [7,8]-                                            then toFlag sharedLibInstallPath-                                            else mempty, -}-                ghcOptHideAllPackages    = toFlag True,-                ghcOptNoAutoLinkPackages = toFlag True,-                ghcOptPackageDBs         = withPackageDB lbi,-                ghcOptThisUnitId = case clbi of-                    LibComponentLocalBuildInfo { componentCompatPackageKey = pk }-                      -> toFlag pk-                    _ -> mempty,-                ghcOptThisComponentId = case clbi of-                    LibComponentLocalBuildInfo { componentInstantiatedWith = insts } ->-                        if null insts-                            then mempty-                            else toFlag (componentComponentId clbi)-                    _ -> mempty,-                ghcOptInstantiatedWith = case clbi of-                    LibComponentLocalBuildInfo { componentInstantiatedWith = insts }-                      -> insts-                    _ -> [],-                ghcOptPackages           = toNubListR $-                                           Internal.mkGhcOptPackages clbi ,-                ghcOptLinkLibs           = extraLibs libBi,-                ghcOptLinkLibPath        = toNubListR $ extraLibDirs libBi,-                ghcOptLinkFrameworks     = toNubListR $ PD.frameworks libBi,-                ghcOptLinkFrameworkDirs  =-                  toNubListR $ PD.extraFrameworkDirs libBi,-                ghcOptRPaths             = rpaths-              }-          ghcStaticLinkArgs =-              mempty {-                ghcOptStaticLib          = toFlag True,-                ghcOptInputFiles         = toNubListR staticObjectFiles,-                ghcOptOutputFile         = toFlag staticLibFilePath,-                ghcOptExtra              = hcStaticOptions GHC libBi,-                ghcOptHideAllPackages    = toFlag True,-                ghcOptNoAutoLinkPackages = toFlag True,-                ghcOptPackageDBs         = withPackageDB lbi,-                ghcOptThisUnitId = case clbi of-                    LibComponentLocalBuildInfo { componentCompatPackageKey = pk }-                      -> toFlag pk-                    _ -> mempty,-                ghcOptThisComponentId = case clbi of-                    LibComponentLocalBuildInfo { componentInstantiatedWith = insts } ->-                        if null insts-                            then mempty-                            else toFlag (componentComponentId clbi)-                    _ -> mempty,-                ghcOptInstantiatedWith = case clbi of-                    LibComponentLocalBuildInfo { componentInstantiatedWith = insts }-                      -> insts-                    _ -> [],-                ghcOptPackages           = toNubListR $-                                           Internal.mkGhcOptPackages clbi ,-                ghcOptLinkLibs           = extraLibs libBi,-                ghcOptLinkLibPath        = toNubListR $ extraLibDirs libBi-              }--      info verbosity (show (ghcOptPackages ghcSharedLinkArgs))-{--      whenVanillaLib False $ do-        Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles-        whenGHCiLib $ do-          (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)-          Ld.combineObjectFiles verbosity lbi ldProg-            ghciLibFilePath staticObjectFiles-            -}-{--      whenProfLib $ do-        Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles-        whenGHCiLib $ do-          (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)-          Ld.combineObjectFiles verbosity lbi ldProg-            ghciProfLibFilePath profObjectFiles--}-      whenSharedLib False $-        runGhcjsProg ghcSharedLinkArgs--      whenStaticLib False $-        runGhcjsProg ghcStaticLinkArgs---- | Start a REPL without loading any source files.-startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform-                 -> PackageDBStack -> IO ()-startInterpreter verbosity progdb comp platform packageDBs = do-  let replOpts = mempty {-        ghcOptMode       = toFlag GhcModeInteractive,-        ghcOptPackageDBs = packageDBs-        }-  checkPackageDbStack verbosity packageDBs-  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb-  runGHC verbosity ghcjsProg comp platform replOpts---- -------------------------------------------------------------------------------- Building an executable or foreign library---- | Build a foreign library-buildFLib-  :: Verbosity          -> Cabal.Flag (Maybe Int)-  -> PackageDescription -> LocalBuildInfo-  -> ForeignLib         -> ComponentLocalBuildInfo -> IO ()-buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib--replFLib-  :: [String]                -> Verbosity-  -> Cabal.Flag (Maybe Int)  -> PackageDescription-  -> LocalBuildInfo          -> ForeignLib-  -> ComponentLocalBuildInfo -> IO ()-replFLib replFlags  v njobs pkg lbi =-  gbuild v njobs pkg lbi . GReplFLib replFlags---- | Build an executable with GHC.----buildExe-  :: Verbosity          -> Cabal.Flag (Maybe Int)-  -> PackageDescription -> LocalBuildInfo-  -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe--replExe-  :: [String]                -> Verbosity-  -> Cabal.Flag (Maybe Int)  -> PackageDescription-  -> LocalBuildInfo          -> Executable-  -> ComponentLocalBuildInfo -> IO ()-replExe replFlags v njobs pkg lbi =-  gbuild v njobs pkg lbi . GReplExe replFlags---- | Building an executable, starting the REPL, and building foreign--- libraries are all very similar and implemented in 'gbuild'. The--- 'GBuildMode' distinguishes between the various kinds of operation.-data GBuildMode =-    GBuildExe  Executable-  | GReplExe   [String] Executable-  | GBuildFLib ForeignLib-  | GReplFLib  [String] ForeignLib--gbuildInfo :: GBuildMode -> BuildInfo-gbuildInfo (GBuildExe  exe)  = buildInfo exe-gbuildInfo (GReplExe   _ exe)  = buildInfo exe-gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib-gbuildInfo (GReplFLib  _ flib) = foreignLibBuildInfo flib--gbuildName :: GBuildMode -> String-gbuildName (GBuildExe  exe)  = unUnqualComponentName $ exeName exe-gbuildName (GReplExe   _ exe)  = unUnqualComponentName $ exeName exe-gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib-gbuildName (GReplFLib  _ flib) = unUnqualComponentName $ foreignLibName flib--gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String-gbuildTargetName lbi (GBuildExe  exe)  = exeTargetName (hostPlatform lbi) exe-gbuildTargetName lbi (GReplExe   _ exe)  = exeTargetName (hostPlatform lbi) exe-gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib-gbuildTargetName lbi (GReplFLib  _ flib) = flibTargetName lbi flib--exeTargetName :: Platform -> Executable -> String-exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform---- | Target name for a foreign library (the actual file name)------ We do not use mkLibName and co here because the naming for foreign libraries--- is slightly different (we don't use "_p" or compiler version suffices, and we--- don't want the "lib" prefix on Windows).------ TODO: We do use `dllExtension` and co here, but really that's wrong: they--- use the OS used to build cabal to determine which extension to use, rather--- than the target OS (but this is wrong elsewhere in Cabal as well).-flibTargetName :: LocalBuildInfo -> ForeignLib -> String-flibTargetName lbi flib =-    case (os, foreignLibType flib) of-      (Windows, ForeignLibNativeShared) -> nm <.> "dll"-      (Windows, ForeignLibNativeStatic) -> nm <.> "lib"-      (Linux,   ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt-      (_other,  ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi)-      (_other,  ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi)-      (_any,    ForeignLibTypeUnknown)  -> cabalBug "unknown foreign lib type"-  where-    nm :: String-    nm = unUnqualComponentName $ foreignLibName flib--    os :: OS-    os = let (Platform _ os') = hostPlatform lbi-         in os'--    -- If a foreign lib foo has lib-version-info 5:1:2 or-    -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1-    -- Libtool's version-info data is translated into library versions in a-    -- nontrivial way: so refer to libtool documentation.-    versionedExt :: String-    versionedExt =-      let nums = foreignLibVersion flib os-      in foldl (<.>) "so" (map show nums)---- | Name for the library when building.------ If the `lib-version-info` field or the `lib-version-linux` field of--- a foreign library target is set, we need to incorporate that--- version into the SONAME field.------ If a foreign library foo has lib-version-info 5:1:2, it should be--- built as libfoo.so.3.2.1.  We want it to get soname libfoo.so.3.--- However, GHC does not allow overriding soname by setting linker--- options, as it sets a soname of its own (namely the output--- filename), after the user-supplied linker options.  Hence, we have--- to compile the library with the soname as its filename.  We rename--- the compiled binary afterwards.------ This method allows to adjust the name of the library at build time--- such that the correct soname can be set.-flibBuildName :: LocalBuildInfo -> ForeignLib -> String-flibBuildName lbi flib-  -- On linux, if a foreign-library has version data, the first digit is used-  -- to produce the SONAME.-  | (os, foreignLibType flib) ==-    (Linux, ForeignLibNativeShared)-  = let nums = foreignLibVersion flib os-    in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums))-  | otherwise = flibTargetName lbi flib-  where-    os :: OS-    os = let (Platform _ os') = hostPlatform lbi-         in os'--    nm :: String-    nm = unUnqualComponentName $ foreignLibName flib--gbuildIsRepl :: GBuildMode -> Bool-gbuildIsRepl (GBuildExe  _) = False-gbuildIsRepl (GReplExe _ _) = True-gbuildIsRepl (GBuildFLib _) = False-gbuildIsRepl (GReplFLib _ _) = True--gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool-gbuildNeedDynamic lbi bm =-    case bm of-      GBuildExe  _    -> withDynExe lbi-      GReplExe   _ _  -> withDynExe lbi-      GBuildFLib flib -> withDynFLib flib-      GReplFLib  _ flib -> withDynFLib flib-  where-    withDynFLib flib =-      case foreignLibType flib of-        ForeignLibNativeShared ->-          ForeignLibStandalone `notElem` foreignLibOptions flib-        ForeignLibNativeStatic ->-          False-        ForeignLibTypeUnknown  ->-          cabalBug "unknown foreign lib type"--gbuildModDefFiles :: GBuildMode -> [FilePath]-gbuildModDefFiles (GBuildExe _)     = []-gbuildModDefFiles (GReplExe  _ _)     = []-gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib-gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib---- | "Main" module name when overridden by @ghc-options: -main-is ...@--- or 'Nothing' if no @-main-is@ flag could be found.------ In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed.-exeMainModuleName :: Executable -> Maybe ModuleName-exeMainModuleName Executable{buildInfo = bnfo} =-    -- GHC honors the last occurrence of a module name updated via -main-is-    ---    -- Moreover, -main-is when parsed left-to-right can update either-    -- the "Main" module name, or the "main" function name, or both,-    -- see also 'decodeMainIsArg'.-    msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts-  where-    ghcopts = hcOptions GHC bnfo--    findIsMainArgs [] = []-    findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest-    findIsMainArgs (_:rest) = findIsMainArgs rest---- | Decode argument to '-main-is'------ Returns 'Nothing' if argument set only the function name.------ This code has been stolen/refactored from GHC's DynFlags.setMainIs--- function. The logic here is deliberately imperfect as it is--- intended to be bug-compatible with GHC's parser. See discussion in--- https://github.com/haskell/cabal/pull/4539#discussion_r118981753.-decodeMainIsArg :: String -> Maybe ModuleName-decodeMainIsArg arg-  | headOf main_fn isLower-                        -- The arg looked like "Foo.Bar.baz"-  = Just (ModuleName.fromString main_mod)-  | headOf arg isUpper  -- The arg looked like "Foo" or "Foo.Bar"-  = Just (ModuleName.fromString arg)-  | otherwise           -- The arg looked like "baz"-  = Nothing-  where-    headOf :: String -> (Char -> Bool) -> Bool-    headOf str pred' = any pred' (safeHead str)--    (main_mod, main_fn) = splitLongestPrefix arg (== '.')--    splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)-    splitLongestPrefix str pred'-      | null r_pre = (str,           [])-      | otherwise  = (reverse (safeTail r_pre), reverse r_suf)-                           -- 'safeTail' drops the char satisfying 'pred'-      where (r_suf, r_pre) = break pred' (reverse str)----- | A collection of:---    * C input files---    * C++ input files---    * GHC input files---    * GHC input modules------ Used to correctly build and link sources.-data BuildSources = BuildSources {-        cSourcesFiles      :: [FilePath],-        cxxSourceFiles     :: [FilePath],-        inputSourceFiles   :: [FilePath],-        inputSourceModules :: [ModuleName]-    }---- | Locate and return the 'BuildSources' required to build and link.-gbuildSources :: Verbosity-              -> CabalSpecVersion-              -> FilePath-              -> GBuildMode-              -> IO BuildSources-gbuildSources verbosity specVer tmpDir bm =-    case bm of-      GBuildExe  exe  -> exeSources exe-      GReplExe   _ exe  -> exeSources exe-      GBuildFLib flib -> return $ flibSources flib-      GReplFLib  _ flib -> return $ flibSources flib-  where-    exeSources :: Executable -> IO BuildSources-    exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do-      main <- findFileEx verbosity (tmpDir : map getSymbolicPath (hsSourceDirs bnfo)) modPath-      let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe-          otherModNames = exeModules exe--      if isHaskell main-        then-          if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames)-          then do-             -- The cabal manual clearly states that `other-modules` is-             -- intended for non-main modules.  However, there's at least one-             -- important package on Hackage (happy-1.19.5) which-             -- violates this. We workaround this here so that we don't-             -- invoke GHC with e.g.  'ghc --make Main src/Main.hs' which-             -- would result in GHC complaining about duplicate Main-             -- modules.-             ---             -- Finally, we only enable this workaround for-             -- specVersion < 2, as 'cabal-version:>=2.0' cabal files-             -- have no excuse anymore to keep doing it wrong... ;-)-             warn verbosity $ "Enabling workaround for Main module '"-                            ++ prettyShow mainModName-                            ++ "' listed in 'other-modules' illegally!"--             return BuildSources {-                        cSourcesFiles      = cSources bnfo,-                        cxxSourceFiles     = cxxSources bnfo,-                        inputSourceFiles   = [main],-                        inputSourceModules = filter (/= mainModName) $ exeModules exe-                    }--          else return BuildSources {-                          cSourcesFiles      = cSources bnfo,-                          cxxSourceFiles     = cxxSources bnfo,-                          inputSourceFiles   = [main],-                          inputSourceModules = exeModules exe-                      }-        else let (csf, cxxsf)-                   | isCxx main = (       cSources bnfo, main : cxxSources bnfo)-                   -- if main is not a Haskell source-                   -- and main is not a C++ source-                   -- then we assume that it is a C source-                   | otherwise  = (main : cSources bnfo,        cxxSources bnfo)--             in  return BuildSources {-                            cSourcesFiles      = csf,-                            cxxSourceFiles     = cxxsf,-                            inputSourceFiles   = [],-                            inputSourceModules = exeModules exe-                        }--    flibSources :: ForeignLib -> BuildSources-    flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} =-        BuildSources {-            cSourcesFiles      = cSources bnfo,-            cxxSourceFiles     = cxxSources bnfo,-            inputSourceFiles   = [],-            inputSourceModules = foreignLibModules flib-        }--    isHaskell :: FilePath -> Bool-    isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"]--    isCxx :: FilePath -> Bool-    isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"]---- | Generic build function. See comment for 'GBuildMode'.-gbuild :: Verbosity          -> Cabal.Flag (Maybe Int)-       -> PackageDescription -> LocalBuildInfo-       -> GBuildMode         -> ComponentLocalBuildInfo -> IO ()-gbuild verbosity numJobs pkg_descr lbi bm clbi = do-  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)-  let replFlags = case bm of-          GReplExe flags _  -> flags-          GReplFLib flags _ -> flags-          GBuildExe{}       -> mempty-          GBuildFLib{}      -> mempty-      comp       = compiler lbi-      platform   = hostPlatform lbi-      implInfo   = getImplInfo comp-      runGhcProg = runGHC verbosity ghcjsProg comp platform--  let (bnfo, threaded) = case bm of-        GBuildFLib _ -> popThreadedFlag (gbuildInfo bm)-        _            -> (gbuildInfo bm, False)--  -- the name that GHC really uses (e.g., with .exe on Windows for executables)-  let targetName = gbuildTargetName lbi bm-  let targetDir  = buildDir lbi </> (gbuildName bm)-  let tmpDir     = targetDir    </> (gbuildName bm ++ "-tmp")-  createDirectoryIfMissingVerbose verbosity True targetDir-  createDirectoryIfMissingVerbose verbosity True tmpDir--  -- 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 = exeCoverage lbi-      distPref = fromFlag $ configDistPref $ configFlags lbi-      hpcdir way-        | gbuildIsRepl bm   = mempty  -- HPC is not supported in ghci-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm)-        | otherwise         = mempty--  rpaths <- getRPaths lbi clbi-  buildSources <- gbuildSources verbosity (specVersion pkg_descr) tmpDir bm--  let cSrcs               = cSourcesFiles buildSources-      cxxSrcs             = cxxSourceFiles buildSources-      inputFiles          = inputSourceFiles buildSources-      inputModules        = inputSourceModules buildSources-      isGhcDynamic        = isDynamic comp-      dynamicTooSupported = supportsDynamicToo comp-      cObjs               = map (`replaceExtension` objExtension) cSrcs-      cxxObjs             = map (`replaceExtension` objExtension) cxxSrcs-      needDynamic         = gbuildNeedDynamic lbi bm-      needProfiling       = withProfExe lbi--  -- build executables-      baseOpts   = (componentGhcOptions verbosity lbi bnfo clbi tmpDir)-                    `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeMake,-                      ghcOptInputFiles   = toNubListR inputFiles,-                      ghcOptInputModules = toNubListR inputModules-                    }-      staticOpts = baseOpts `mappend` mempty {-                      ghcOptDynLinkMode    = toFlag GhcStaticOnly,-                      ghcOptHPCDir         = hpcdir Hpc.Vanilla-                   }-      profOpts   = baseOpts `mappend` mempty {-                      ghcOptProfilingMode  = toFlag True,-                      ghcOptProfilingAuto  = Internal.profDetailLevelFlag False-                                             (withProfExeDetail lbi),-                      ghcOptHiSuffix       = toFlag "p_hi",-                      ghcOptObjSuffix      = toFlag "p_o",-                      ghcOptExtra          = hcProfOptions GHC bnfo,-                      ghcOptHPCDir         = hpcdir Hpc.Prof-                    }-      dynOpts    = baseOpts `mappend` mempty {-                      ghcOptDynLinkMode    = toFlag GhcDynamicOnly,-                      -- TODO: Does it hurt to set -fPIC for executables?-                      ghcOptFPic           = toFlag True,-                      ghcOptHiSuffix       = toFlag "dyn_hi",-                      ghcOptObjSuffix      = toFlag "dyn_o",-                      ghcOptExtra          = hcSharedOptions GHC bnfo,-                      ghcOptHPCDir         = hpcdir Hpc.Dyn-                    }-      dynTooOpts = staticOpts `mappend` mempty {-                      ghcOptDynLinkMode    = toFlag GhcStaticAndDynamic,-                      ghcOptDynHiSuffix    = toFlag "dyn_hi",-                      ghcOptDynObjSuffix   = toFlag "dyn_o",-                      ghcOptHPCDir         = hpcdir Hpc.Dyn-                    }-      linkerOpts = mempty {-                      ghcOptLinkOptions       = PD.ldOptions bnfo,-                      ghcOptLinkLibs          = extraLibs bnfo,-                      ghcOptLinkLibPath       = toNubListR $ extraLibDirs bnfo,-                      ghcOptLinkFrameworks    = toNubListR $-                                                PD.frameworks bnfo,-                      ghcOptLinkFrameworkDirs = toNubListR $-                                                PD.extraFrameworkDirs bnfo,-                      ghcOptInputFiles     = toNubListR-                                             [tmpDir </> x | x <- cObjs ++ cxxObjs]-                    }-      dynLinkerOpts = mempty {-                      ghcOptRPaths         = rpaths-                   }-      replOpts   = baseOpts {-                    ghcOptExtra            = Internal.filterGhciFlags-                                             (ghcOptExtra baseOpts)-                                             <> replFlags-                   }-                   -- For a normal compile we do separate invocations of ghc for-                   -- compiling as for linking. But for repl we have to do just-                   -- the one invocation, so that one has to include all the-                   -- linker stuff too, like -l flags and any .o files from C-                   -- files etc.-                   `mappend` linkerOpts-                   `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeInteractive,-                      ghcOptOptimisation = toFlag GhcNoOptimisation-                     }-      commonOpts  | needProfiling = profOpts-                  | needDynamic   = dynOpts-                  | otherwise     = staticOpts-      compileOpts | useDynToo = dynTooOpts-                  | otherwise = commonOpts-      withStaticExe = not needProfiling && not needDynamic--      -- For building exe's that use TH with -prof or -dynamic we actually have-      -- to build twice, once without -prof/-dynamic and then again with-      -- -prof/-dynamic. This is because the code that TH needs to run at-      -- compile time needs to be the vanilla ABI so it can be loaded up and run-      -- by the compiler.-      -- With dynamic-by-default GHC the TH object files loaded at compile-time-      -- need to be .dyn_o instead of .o.-      doingTH = usesTemplateHaskellOrQQ bnfo-      -- Should we use -dynamic-too instead of compiling twice?-      useDynToo = dynamicTooSupported && isGhcDynamic-                  && doingTH && withStaticExe-                  && null (hcSharedOptions GHC bnfo)-      compileTHOpts | isGhcDynamic = dynOpts-                    | otherwise    = staticOpts-      compileForTH-        | gbuildIsRepl bm = False-        | useDynToo       = False-        | isGhcDynamic    = doingTH && (needProfiling || withStaticExe)-        | otherwise       = doingTH && (needProfiling || needDynamic)--   -- Build static/dynamic object files for TH, if needed.-  when compileForTH $-    runGhcProg compileTHOpts { ghcOptNoLink  = toFlag True-                             , ghcOptNumJobs = numJobs }--  -- Do not try to build anything if there are no input files.-  -- This can happen if the cabal file ends up with only cSrcs-  -- but no Haskell modules.-  unless ((null inputFiles && null inputModules)-          || gbuildIsRepl bm) $-    runGhcProg compileOpts { ghcOptNoLink  = toFlag True-                           , ghcOptNumJobs = numJobs }--  -- build any C++ sources-  unless (null cxxSrcs) $ do-   info verbosity "Building C++ Sources..."-   sequence_-     [ do let baseCxxOpts    = Internal.componentCxxGhcOptions verbosity implInfo-                               lbi bnfo clbi tmpDir filename-              vanillaCxxOpts = if isGhcDynamic-                                -- Dynamic GHC requires C++ sources to be built-                                -- with -fPIC for REPL to work. See #2207.-                               then baseCxxOpts { ghcOptFPic = toFlag True }-                               else baseCxxOpts-              profCxxOpts    = vanillaCxxOpts `mappend` mempty {-                                 ghcOptProfilingMode = toFlag True-                               }-              sharedCxxOpts  = vanillaCxxOpts `mappend` mempty {-                                 ghcOptFPic        = toFlag True,-                                 ghcOptDynLinkMode = toFlag GhcDynamicOnly-                               }-              opts | needProfiling = profCxxOpts-                   | needDynamic   = sharedCxxOpts-                   | otherwise     = vanillaCxxOpts-              -- TODO: Placing all Haskell, C, & C++ objects in a single directory-              --       Has the potential for file collisions. In general we would-              --       consider this a user error. However, we should strive to-              --       add a warning if this occurs.-              odir = fromFlag (ghcOptObjDir opts)-          createDirectoryIfMissingVerbose verbosity True odir-          needsRecomp <- checkNeedsRecompilation filename opts-          when needsRecomp $-            runGhcProg opts-     | filename <- cxxSrcs ]--  -- build any C sources-  unless (null cSrcs) $ do-   info verbosity "Building C Sources..."-   sequence_-     [ do let baseCcOpts    = Internal.componentCcGhcOptions verbosity implInfo-                              lbi bnfo clbi tmpDir filename-              vanillaCcOpts = if isGhcDynamic-                              -- Dynamic GHC requires C sources to be built-                              -- with -fPIC for REPL to work. See #2207.-                              then baseCcOpts { ghcOptFPic = toFlag True }-                              else baseCcOpts-              profCcOpts    = vanillaCcOpts `mappend` mempty {-                                ghcOptProfilingMode = toFlag True-                              }-              sharedCcOpts  = vanillaCcOpts `mappend` mempty {-                                ghcOptFPic        = toFlag True,-                                ghcOptDynLinkMode = toFlag GhcDynamicOnly-                              }-              opts | needProfiling = profCcOpts-                   | needDynamic   = sharedCcOpts-                   | otherwise     = vanillaCcOpts-              odir = fromFlag (ghcOptObjDir opts)-          createDirectoryIfMissingVerbose verbosity True odir-          needsRecomp <- checkNeedsRecompilation filename opts-          when needsRecomp $-            runGhcProg opts-     | filename <- cSrcs ]--  -- TODO: problem here is we need the .c files built first, so we can load them-  -- with ghci, but .c files can depend on .h files generated by ghc by ffi-  -- exports.-  case bm of-    GReplExe  _ _ -> runGhcProg replOpts-    GReplFLib _ _ -> runGhcProg replOpts-    GBuildExe _ -> do-      let linkOpts = commonOpts-                   `mappend` linkerOpts-                   `mappend` mempty {-                      ghcOptLinkNoHsMain = toFlag (null inputFiles)-                     }-                   `mappend` (if withDynExe lbi then dynLinkerOpts else mempty)--      info verbosity "Linking..."-      -- Work around old GHCs not relinking in this-      -- situation, see #3294-      let target = targetDir </> targetName-      when (compilerVersion comp < mkVersion [7,7]) $ do-        e <- doesFileExist target-        when e (removeFile target)-      runGhcProg linkOpts { ghcOptOutputFile = toFlag target }-    GBuildFLib flib -> do-      let rtsInfo  = extractRtsInfo lbi-          rtsOptLinkLibs = [-              if needDynamic-                  then if threaded-                            then dynRtsThreadedLib (rtsDynamicInfo rtsInfo)-                            else dynRtsVanillaLib (rtsDynamicInfo rtsInfo)-                  else if threaded-                           then statRtsThreadedLib (rtsStaticInfo rtsInfo)-                           else statRtsVanillaLib (rtsStaticInfo rtsInfo)-              ]-          linkOpts = case foreignLibType flib of-            ForeignLibNativeShared ->-                        commonOpts-              `mappend` linkerOpts-              `mappend` dynLinkerOpts-              `mappend` mempty {-                 ghcOptLinkNoHsMain    = toFlag True,-                 ghcOptShared          = toFlag True,-                 ghcOptLinkLibs        = rtsOptLinkLibs,-                 ghcOptLinkLibPath     = toNubListR $ rtsLibPaths rtsInfo,-                 ghcOptFPic            = toFlag True,-                 ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm-                }-              -- See Note [RPATH]-              `mappend` ifNeedsRPathWorkaround lbi mempty {-                  ghcOptLinkOptions = ["-Wl,--no-as-needed"]-                , ghcOptLinkLibs    = ["ffi"]-                }-            ForeignLibNativeStatic ->-              -- this should be caught by buildFLib-              -- (and if we do implement this, we probably don't even want to call-              -- ghc here, but rather Ar.createArLibArchive or something)-              cabalBug "static libraries not yet implemented"-            ForeignLibTypeUnknown ->-              cabalBug "unknown foreign lib type"-      -- We build under a (potentially) different filename to set a-      -- soname on supported platforms.  See also the note for-      -- @flibBuildName@.-      info verbosity "Linking..."-      let buildName = flibBuildName lbi flib-      runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> buildName) }-      renameFile (targetDir </> buildName) (targetDir </> targetName)--{--Note [RPATH]-~~~~~~~~~~~~--Suppose that the dynamic library depends on `base`, but not (directly) on-`integer-gmp` (which, however, is a dependency of `base`). We will link the-library as--    gcc ... -lHSbase-4.7.0.2-ghc7.8.4 -lHSinteger-gmp-0.5.1.0-ghc7.8.4 ...--However, on systems (like Ubuntu) where the linker gets called with `-as-needed`-by default, the linker will notice that `integer-gmp` isn't actually a direct-dependency and hence omit the link.--Then when we attempt to link a C program against this dynamic library, the-_static_ linker will attempt to verify that all symbols can be resolved.  The-dynamic library itself does not require any symbols from `integer-gmp`, but-`base` does. In order to verify that the symbols used by `base` can be-resolved, the static linker needs to be able to _find_ integer-gmp.--Finding the `base` dependency is simple, because the dynamic elf header-(`readelf -d`) for the library that we have created looks something like--    (NEEDED) Shared library: [libHSbase-4.7.0.2-ghc7.8.4.so]-    (RPATH)  Library rpath: [/path/to/base-4.7.0.2:...]--However, when it comes to resolving the dependency on `integer-gmp`, it needs-to look at the dynamic header for `base`. On modern ghc (7.8 and higher) this-looks something like--    (NEEDED) Shared library: [libHSinteger-gmp-0.5.1.0-ghc7.8.4.so]-    (RPATH)  Library rpath: [$ORIGIN/../integer-gmp-0.5.1.0:...]--This specifies the location of `integer-gmp` _in terms of_ the location of base-(using the `$ORIGIN`) variable. But here's the crux: when the static linker-attempts to verify that all symbols can be resolved, [**IT DOES NOT RESOLVE-`$ORIGIN`**](http://stackoverflow.com/questions/6323603/ld-using-rpath-origin-inside-a-shared-library-recursive).-As a consequence, it will not be able to resolve the symbols and report the-missing symbols as errors, _even though the dynamic linker **would** be able to-resolve these symbols_. We can tell the static linker not to report these-errors by using `--unresolved-symbols=ignore-all` and all will be fine when we-run the program ([(indeed, this is what the gold linker-does)](https://sourceware.org/ml/binutils/2013-05/msg00038.html), but it makes-the resulting library more difficult to use.--Instead what we can do is make sure that the generated dynamic library has-explicit top-level dependencies on these libraries. This means that the static-linker knows where to find them, and when we have transitive dependencies on-the same libraries the linker will only load them once, so we avoid needing to-look at the `RPATH` of our dependencies. We can do this by passing-`--no-as-needed` to the linker, so that it doesn't omit any libraries.--Note that on older ghc (7.6 and before) the Haskell libraries don't have an-RPATH set at all, which makes it even more important that we make these-top-level dependencies.--Finally, we have to explicitly link against `libffi` for the same reason. For-newer ghc this _happens_ to be unnecessary on many systems because `libffi` is-a library which is not specific to GHC, and when the static linker verifies-that all symbols can be resolved it will find the `libffi` that is globally-installed (completely independent from ghc). Of course, this may well be the-_wrong_ version of `libffi`, but it's quite possible that symbol resolution-happens to work. This is of course the wrong approach, which is why we link-explicitly against `libffi` so that we will find the _right_ version of-`libffi`.--}---- | Do we need the RPATH workaround?------ See Note [RPATH].-ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a-ifNeedsRPathWorkaround lbi a =-  case hostPlatform lbi of-    Platform _ Linux -> a-    _otherwise       -> mempty--data DynamicRtsInfo = DynamicRtsInfo {-    dynRtsVanillaLib          :: FilePath-  , dynRtsThreadedLib         :: FilePath-  , dynRtsDebugLib            :: FilePath-  , dynRtsEventlogLib         :: FilePath-  , dynRtsThreadedDebugLib    :: FilePath-  , dynRtsThreadedEventlogLib :: FilePath-  }--data StaticRtsInfo = StaticRtsInfo {-    statRtsVanillaLib           :: FilePath-  , statRtsThreadedLib          :: FilePath-  , statRtsDebugLib             :: FilePath-  , statRtsEventlogLib          :: FilePath-  , statRtsThreadedDebugLib     :: FilePath-  , statRtsThreadedEventlogLib  :: FilePath-  , statRtsProfilingLib         :: FilePath-  , statRtsThreadedProfilingLib :: FilePath-  }--data RtsInfo = RtsInfo {-    rtsDynamicInfo :: DynamicRtsInfo-  , rtsStaticInfo  :: StaticRtsInfo-  , rtsLibPaths    :: [FilePath]-  }---- | Extract (and compute) information about the RTS library------ TODO: This hardcodes the name as @HSrts-ghc<version>@. I don't know if we can--- find this information somewhere. We can lookup the 'hsLibraries' field of--- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which--- doesn't really help.-extractRtsInfo :: LocalBuildInfo -> RtsInfo-extractRtsInfo lbi =-    case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of-      [(_, [rts])] -> aux rts-      _otherwise   -> error "No (or multiple) ghc rts package is registered"-  where-    aux :: InstalledPackageInfo -> RtsInfo-    aux rts = RtsInfo {-        rtsDynamicInfo = DynamicRtsInfo {-            dynRtsVanillaLib          = withGhcVersion "HSrts"-          , dynRtsThreadedLib         = withGhcVersion "HSrts_thr"-          , dynRtsDebugLib            = withGhcVersion "HSrts_debug"-          , dynRtsEventlogLib         = withGhcVersion "HSrts_l"-          , dynRtsThreadedDebugLib    = withGhcVersion "HSrts_thr_debug"-          , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l"-          }-      , rtsStaticInfo = StaticRtsInfo {-            statRtsVanillaLib           = "HSrts"-          , statRtsThreadedLib          = "HSrts_thr"-          , statRtsDebugLib             = "HSrts_debug"-          , statRtsEventlogLib          = "HSrts_l"-          , statRtsThreadedDebugLib     = "HSrts_thr_debug"-          , statRtsThreadedEventlogLib  = "HSrts_thr_l"-          , statRtsProfilingLib         = "HSrts_p"-          , statRtsThreadedProfilingLib = "HSrts_thr_p"-          }-      , rtsLibPaths   = InstalledPackageInfo.libraryDirs rts-      }-    withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi))))---- | Returns True if the modification date of the given source file is newer than--- the object file we last compiled for it, or if no object file exists yet.-checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool-checkNeedsRecompilation filename opts = filename `moreRecentFile` oname-    where oname = getObjectFileName filename opts---- | Finds the object file name of the given source file-getObjectFileName :: FilePath -> GhcOptions -> FilePath-getObjectFileName filename opts = oname-    where odir  = fromFlag (ghcOptObjDir opts)-          oext  = fromFlagOrDefault "o" (ghcOptObjSuffix opts)-          oname = odir </> replaceExtension filename oext---- | Calculate the RPATHs for the component we are building.------ Calculates relative RPATHs when 'relocatable' is set.-getRPaths :: LocalBuildInfo-          -> ComponentLocalBuildInfo -- ^ Component we are building-          -> IO (NubListR FilePath)-getRPaths lbi clbi | supportRPaths hostOS = do-    libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi-    let hostPref = case hostOS of-                     OSX -> "@loader_path"-                     _   -> "$ORIGIN"-        relPath p = if isRelative p then hostPref </> p else p-        rpaths    = toNubListR (map relPath libraryPaths)-    return rpaths-  where-    (Platform _ hostOS) = hostPlatform lbi-    compid              = compilerId . compiler $ lbi--    -- The list of RPath-supported operating systems below reflects the-    -- platforms on which Cabal's RPATH handling is tested. It does _NOT_-    -- reflect whether the OS supports RPATH.--    -- E.g. when this comment was written, the *BSD operating systems were-    -- untested with regards to Cabal RPATH handling, and were hence set to-    -- 'False', while those operating systems themselves do support RPATH.-    supportRPaths Linux       = True-    supportRPaths Windows     = False-    supportRPaths OSX         = True-    supportRPaths FreeBSD     =-      case compid of-        CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True-        _                                              -> False-    supportRPaths OpenBSD     = False-    supportRPaths NetBSD      = False-    supportRPaths DragonFly   = False-    supportRPaths Solaris     = False-    supportRPaths AIX         = False-    supportRPaths HPUX        = False-    supportRPaths IRIX        = False-    supportRPaths HaLVM       = False-    supportRPaths IOS         = False-    supportRPaths Android     = False-    supportRPaths Ghcjs       = False-    supportRPaths Hurd        = False-    supportRPaths (OtherOS _) = False-    -- Do _not_ add a default case so that we get a warning here when a new OS-    -- is added.--getRPaths _ _ = return mempty---- | Remove the "-threaded" flag when building a foreign library, as it has no---   effect when used with "-shared". Returns the updated 'BuildInfo', along---   with whether or not the flag was present, so we can use it to link against---   the appropriate RTS on our own.-popThreadedFlag :: BuildInfo -> (BuildInfo, Bool)-popThreadedFlag bi =-  ( bi { options = filterHcOptions (/= "-threaded") (options bi) }-  , hasThreaded (options bi))--  where-    filterHcOptions :: (String -> Bool)-                    -> PerCompilerFlavor [String]-                    -> PerCompilerFlavor [String]-    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 :: Verbosity -> PackageDescription -> LocalBuildInfo-           -> Library -> ComponentLocalBuildInfo -> IO String-libAbiHash verbosity _pkg_descr lbi lib clbi = do-  let-      libBi = libBuildInfo lib-      comp        = compiler lbi-      platform    = hostPlatform lbi-      vanillaArgs0 =-        (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi))-        `mappend` mempty {-          ghcOptMode         = toFlag GhcModeAbiHash,-          ghcOptInputModules = toNubListR $ exposedModules lib-        }-      vanillaArgs =-          -- Package DBs unnecessary, and break ghc-cabal. See #3633-          -- BUT, put at least the global database so that 7.4 doesn't-          -- break.-          vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB]-                       , ghcOptPackages = mempty }-      sharedArgs = vanillaArgs `mappend` mempty {-                       ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                       ghcOptFPic        = toFlag True,-                       ghcOptHiSuffix    = toFlag "js_dyn_hi",-                       ghcOptObjSuffix   = toFlag "js_dyn_o",-                       ghcOptExtra       = hcSharedOptions GHC libBi-                   }-      profArgs   = vanillaArgs `mappend` mempty {-                     ghcOptProfilingMode = toFlag True,-                     ghcOptProfilingAuto = Internal.profDetailLevelFlag True-                                             (withProfLibDetail lbi),-                     ghcOptHiSuffix      = toFlag "js_p_hi",-                     ghcOptObjSuffix     = toFlag "js_p_o",-                     ghcOptExtra         = hcProfOptions GHC libBi-                   }-      ghcArgs-        | withVanillaLib lbi = vanillaArgs-        | withSharedLib lbi = sharedArgs-        | withProfLib lbi = profArgs-        | otherwise = error "libAbiHash: Can't find an enabled library way"--  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)-  hash <- getProgramInvocationOutput verbosity-          (ghcInvocation ghcjsProg comp platform ghcArgs)-  return (takeWhile (not . isSpace) hash)--componentGhcOptions :: Verbosity -> LocalBuildInfo-                    -> BuildInfo -> ComponentLocalBuildInfo -> FilePath-                    -> GhcOptions-componentGhcOptions verbosity lbi bi clbi odir =-  let opts = Internal.componentGhcOptions verbosity implInfo lbi bi clbi odir-      comp = compiler lbi-      implInfo = getImplInfo comp-  in  opts { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi-           }---componentCcGhcOptions :: Verbosity -> LocalBuildInfo-                      -> BuildInfo -> ComponentLocalBuildInfo-                      -> FilePath -> FilePath-                      -> GhcOptions-componentCcGhcOptions verbosity lbi =-    Internal.componentCcGhcOptions verbosity implInfo lbi-  where-    comp     = compiler lbi-    implInfo = getImplInfo comp----- -------------------------------------------------------------------------------- Installing---- |Install executables for GHCJS.-installExe :: Verbosity-           -> LocalBuildInfo-           -> FilePath -- ^Where to copy the files to-           -> FilePath  -- ^Build location-           -> (FilePath, FilePath)  -- ^Executable (prefix,suffix)-           -> PackageDescription-           -> Executable-           -> IO ()-installExe verbosity lbi binDir buildPref-           (progprefix, progsuffix) _pkg exe = do-  createDirectoryIfMissingVerbose verbosity True binDir-  let exeName' = unUnqualComponentName $ exeName exe-      exeFileName = exeName'-      fixedExeBaseName = progprefix ++ exeName' ++ progsuffix-      installBinary dest = do-        runDbProgram verbosity ghcjsProgram (withPrograms lbi) $-          [ "--install-executable"-          , buildPref </> exeName' </> exeFileName-          , "-o", dest-          ] ++-          case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of-           (True, Just strip) -> ["-strip-program", programPath strip]-           _                  -> []-  installBinary (binDir </> fixedExeBaseName)----- |Install foreign library for GHC.-installFLib :: Verbosity-            -> LocalBuildInfo-            -> FilePath  -- ^install location-            -> FilePath  -- ^Build location-            -> PackageDescription-            -> ForeignLib-            -> IO ()-installFLib verbosity lbi targetDir builtDir _pkg flib =-    install (foreignLibIsShared flib)-            builtDir-            targetDir-            (flibTargetName lbi flib)-  where-    install _isShared srcDir dstDir name = do-      let src = srcDir </> name-          dst = dstDir </> name-      createDirectoryIfMissingVerbose verbosity True targetDir-      installOrdinaryFile   verbosity src dst----- |Install for ghc, .hi, .a and, if --with-ghci given, .o-installLib    :: Verbosity-              -> LocalBuildInfo-              -> FilePath  -- ^install location-              -> FilePath  -- ^install location for dynamic libraries-              -> FilePath  -- ^Build location-              -> PackageDescription-              -> Library-              -> ComponentLocalBuildInfo-              -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do-  whenVanilla $ copyModuleFiles "js_hi"-  whenProf    $ copyModuleFiles "js_p_hi"-  whenShared  $ copyModuleFiles "js_dyn_hi"--  -- whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName-  -- whenProf    $ installOrdinary builtDir targetDir $ toJSLibName profileLibName-  -- whenShared  $ installShared   builtDir dynlibTargetDir $ toJSLibName sharedLibName-  -- fixme do these make the correct lib names?-  whenHasCode $ do-    whenVanilla $ do-      sequence_ [ installOrdinary builtDir' targetDir       (toJSLibName $ mkGenericStaticLibName (l ++ f))-                | l <- getHSLibraryName (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib))-                , f <- "":extraLibFlavours (libBuildInfo lib)-                ]-      -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName)-    whenProf $ do-      installOrdinary builtDir' targetDir (toJSLibName profileLibName)-      -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName)-    whenShared  $-      sequence_ [ installShared builtDir' dynlibTargetDir-                    (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f))-                | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib)-                , f <- "":extraDynLibFlavours (libBuildInfo lib)-                ]-  where-    builtDir' = componentBuildDir lbi clbi--    install isShared isJS srcDir dstDir name = do-      let src = srcDir </> name-          dst = dstDir </> name-      createDirectoryIfMissingVerbose verbosity True dstDir--      if isShared-        then installExecutableFile verbosity src dst-        else installOrdinaryFile   verbosity src dst--      when (stripLibs lbi && not isJS) $-        Strip.stripLib verbosity-        (hostPlatform lbi) (withPrograms lbi) dst--    installOrdinary = install False True-    installShared   = install True  True--    copyModuleFiles ext =-      findModuleFilesEx verbosity [builtDir'] [ext] (allLibModules lib clbi)-      >>= installOrdinaryFiles verbosity targetDir--    compiler_id = compilerId (compiler lbi)-    platform = hostPlatform lbi-    uid = componentUnitId clbi-    -- vanillaLibName = mkLibName              uid-    profileLibName = mkProfLibName          uid-    -- sharedLibName  = (mkSharedLibName (hostPlatform lbi) compiler_id)  uid--    hasLib    = not $ null (allLibModules lib clbi)-                   && null (cSources (libBuildInfo lib))-                   && null (cxxSources (libBuildInfo lib))-                   && null (jsSources (libBuildInfo lib))-    has_code = not (componentIsIndefinite clbi)-    whenHasCode = when has_code-    whenVanilla = when (hasLib && withVanillaLib lbi)-    whenProf    = when (hasLib && withProfLib    lbi && has_code)-    -- whenGHCi    = when (hasLib && withGHCiLib    lbi && has_code)-    whenShared  = when (hasLib && withSharedLib  lbi && has_code)---adjustExts :: String -> String -> GhcOptions -> GhcOptions-adjustExts hiSuf objSuf opts =-  opts `mappend` mempty {-    ghcOptHiSuffix  = toFlag hiSuf,-    ghcOptObjSuffix = toFlag objSuf-  }--isDynamic :: Compiler -> Bool-isDynamic = Internal.ghcLookupProperty "GHC Dynamic"--supportsDynamicToo :: Compiler -> Bool-supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"--withExt :: FilePath -> String -> FilePath-withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else ""--findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version)-findGhcjsGhcVersion verbosity pgm =-  findProgramVersion "--numeric-ghc-version" id verbosity pgm--findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version)-findGhcjsPkgGhcjsVersion verbosity pgm =-  findProgramVersion "--numeric-ghcjs-version" id verbosity pgm---- -------------------------------------------------------------------------------- Registering--hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo-hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = ghcjsPkgProg-                                   , HcPkg.noPkgDbStack    = False-                                   , HcPkg.noVerboseFlag   = False-                                   , HcPkg.flagPackageConf = False-                                   , HcPkg.supportsDirDbs  = True-                                   , HcPkg.requiresDirDbs  = ver >= v7_10-                                   , HcPkg.nativeMultiInstance  = ver >= v7_10-                                   , HcPkg.recacheMultiInstance = True-                                   , HcPkg.suppressFilesCheck   = True-                                   }-  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--registerPackage-  :: Verbosity-  -> ProgramDb-  -> PackageDBStack-  -> InstalledPackageInfo-  -> HcPkg.RegisterOptions-  -> IO ()-registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions =-    HcPkg.register (hcPkgInfo progdb) verbosity packageDbs-                   installedPkgInfo registerOptions--pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath-pkgRoot verbosity lbi = pkgRoot'-   where-    pkgRoot' GlobalPackageDB =-      let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi)-      in  fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg)-    pkgRoot' UserPackageDB = do-      appDir <- getAppUserDataDirectory "ghcjs"-      -- fixme correct this version-      let ver      = compilerVersion (compiler lbi)-          subdir   = System.Info.arch ++ '-':System.Info.os-                     ++ '-':prettyShow ver-          rootDir  = appDir </> subdir-      -- We must create the root directory for the user package database if it-      -- does not yet exists. Otherwise '${pkgroot}' will resolve to a-      -- directory at the time of 'ghc-pkg register', and registration will-      -- fail.-      createDirectoryIfMissing True rootDir-      return rootDir-    pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp)----- | Get the JavaScript file name and command and arguments to run a---   program compiled by GHCJS---   the exe should be the base program name without exe extension-runCmd :: ProgramDb -> FilePath-            -> (FilePath, FilePath, [String])+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Distribution.Simple.GHCJS+  ( getGhcInfo+  , configure+  , configureCompiler+  , compilerProgramDb+  , getInstalledPackages+  , getInstalledPackagesMonitorFiles+  , getPackageDBContents+  , buildLib+  , buildFLib+  , buildExe+  , replLib+  , replFLib+  , replExe+  , startInterpreter+  , installLib+  , installFLib+  , installExe+  , libAbiHash+  , hcPkgInfo+  , registerPackage+  , componentGhcOptions+  , Internal.componentCcGhcOptions+  , getLibDir+  , isDynamic+  , getGlobalPackageDB+  , pkgRoot+  , runCmd++    -- * Constructing and deconstructing GHC environment files+  , Internal.GhcEnvironmentFileEntry (..)+  , Internal.simpleGhcEnvironmentFile+  , Internal.renderGhcEnvironmentFile+  , Internal.writeGhcEnvironmentFile+  , Internal.ghcPlatformAndVersionString+  , readGhcEnvironmentFile+  , parseGhcEnvironmentFile+  , ParseErrorExc (..)++    -- * Version-specific implementation quirks+  , getImplInfo+  , GhcImplInfo (..)+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.CabalSpecVersion+import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo+import Distribution.ModuleName (ModuleName)+import qualified Distribution.ModuleName as ModuleName+import Distribution.Package+import Distribution.PackageDescription as PD+import Distribution.PackageDescription.Utils (cabalBug)+import Distribution.Pretty+import Distribution.Simple.BuildPaths+import Distribution.Simple.Compiler+import Distribution.Simple.Errors+import Distribution.Simple.Flag+import Distribution.Simple.GHC.EnvironmentParser+import Distribution.Simple.GHC.ImplInfo+import qualified Distribution.Simple.GHC.Internal as Internal+import qualified Distribution.Simple.Hpc as Hpc+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PreProcess.Types+import Distribution.Simple.Program+import Distribution.Simple.Program.GHC+import qualified Distribution.Simple.Program.HcPkg as HcPkg+import qualified Distribution.Simple.Program.Strip as Strip+import Distribution.Simple.Setup.Common+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.PackageName.Magic+import Distribution.Types.ParStrat+import Distribution.Utils.NubList+import Distribution.Utils.Path+import Distribution.Verbosity (Verbosity)+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+  ( isRelative+  , replaceExtension+  , takeDirectory+  , takeExtension+  )+import qualified System.Info++-- -----------------------------------------------------------------------------+-- Configuring++-- | Configure GHCJS, and then auxiliary programs such as @ghc-pkg@, @haddock@+-- as well as toolchain programs such as @ar@, @ld.+configure+  :: Verbosity+  -> Maybe FilePath+  -- ^ user-specified @ghcjs@ path (optional)+  -> Maybe FilePath+  -- ^ user-specified @ghcjs-pkg@ path (optional)+  -> ProgramDb+  -> IO (Compiler, Maybe Platform, ProgramDb)+configure verbosity hcPath hcPkgPath conf0 = do+  (comp, compPlatform, progdb1) <- configureCompiler verbosity hcPath conf0+  compProgDb <- compilerProgramDb verbosity comp progdb1 hcPkgPath+  return (comp, compPlatform, compProgDb)++-- | Configure GHCJS.+configureCompiler+  :: Verbosity+  -> Maybe FilePath+  -- ^ user-specified @ghc@ path (optional)+  -> ProgramDb+  -> IO (Compiler, Maybe Platform, ProgramDb)+configureCompiler verbosity hcPath conf0 = do+  (ghcjsProg, ghcjsVersion, progdb1) <-+    requireProgramVersion+      verbosity+      ghcjsProgram+      (orLaterVersion (mkVersion [0, 1]))+      (userMaybeSpecifyPath "ghcjs" hcPath conf0)++  Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg)+  unless (ghcjsGhcVersion < mkVersion [8, 8]) $+    warn verbosity $+      "Unknown/unsupported 'ghc' version detected "+        ++ "(Cabal "+        ++ prettyShow cabalVersion+        ++ " supports 'ghc' version < 8.8): "+        ++ programPath ghcjsProg+        ++ " is based on GHC version "+        ++ prettyShow ghcjsGhcVersion++  let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion++  languages <- Internal.getLanguages verbosity implInfo ghcjsProg+  extensions <- Internal.getExtensions verbosity implInfo ghcjsProg++  ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg+  let ghcInfoMap = Map.fromList ghcjsInfo++  let comp =+        Compiler+          { compilerId = CompilerId GHCJS ghcjsVersion+          , compilerAbiTag =+              AbiTag $+                "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion)+          , compilerCompat = [CompilerId GHC ghcjsGhcVersion]+          , compilerLanguages = languages+          , compilerExtensions = extensions+          , compilerProperties = ghcInfoMap+          }+      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:+  (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <-+    requireProgramVersion+      verbosity+      ghcjsPkgProgram+        { programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg+        }+      anyVersion+      (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1)++  Just ghcjsPkgGhcjsVersion <-+    findGhcjsPkgGhcjsVersion+      verbosity+      (programPath ghcjsPkgProg)++  when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $+    dieWithException verbosity $+      VersionMismatchJS+        (programPath ghcjsProg)+        ghcjsVersion+        (programPath ghcjsPkgProg)+        ghcjsPkgGhcjsVersion++  when (ghcjsGhcVersion /= ghcjsPkgVersion) $+    dieWithException verbosity $+      VersionMismatchGHCJS (programPath ghcjsProg) ghcjsGhcVersion (programPath ghcjsPkgProg) ghcjsPkgVersion++  -- Likewise we try to find the matching hsc2hs and haddock programs.+  let hsc2hsProgram' =+        hsc2hsProgram+          { programFindLocation =+              guessHsc2hsFromGhcjsPath ghcjsProg+          }+      haddockProgram' =+        haddockProgram+          { programFindLocation =+              guessHaddockFromGhcjsPath ghcjsProg+          }+      hpcProgram' =+        hpcProgram+          { programFindLocation = guessHpcFromGhcjsPath ghcjsProg+          }+      {-+      runghcProgram' = runghcProgram {+                        programFindLocation = guessRunghcFromGhcjsPath ghcjsProg+                    } -}+      progdb3 =+        addKnownProgram haddockProgram' $+          addKnownProgram hsc2hsProgram' $+            addKnownProgram hpcProgram' $+              {- addKnownProgram runghcProgram' -} progdb2++  return progdb3++guessGhcjsPkgFromGhcjsPath+  :: ConfiguredProgram+  -> Verbosity+  -> ProgramSearchPath+  -> IO (Maybe (FilePath, [FilePath]))+guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram++guessHsc2hsFromGhcjsPath+  :: ConfiguredProgram+  -> Verbosity+  -> ProgramSearchPath+  -> IO (Maybe (FilePath, [FilePath]))+guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram++guessHaddockFromGhcjsPath+  :: ConfiguredProgram+  -> Verbosity+  -> ProgramSearchPath+  -> IO (Maybe (FilePath, [FilePath]))+guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram++guessHpcFromGhcjsPath+  :: ConfiguredProgram+  -> Verbosity+  -> ProgramSearchPath+  -> IO (Maybe (FilePath, [FilePath]))+guessHpcFromGhcjsPath = guessToolFromGhcjsPath hpcProgram++guessToolFromGhcjsPath+  :: Program+  -> ConfiguredProgram+  -> Verbosity+  -> ProgramSearchPath+  -> IO (Maybe (FilePath, [FilePath]))+guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath =+  do+    let toolname = programName tool+        given_path = programPath ghcjsProg+        given_dir = takeDirectory given_path+    real_path <- canonicalizePath given_path+    let real_dir = takeDirectory real_path+        versionSuffix path = takeVersionSuffix (dropExeExtension path)+        given_suf = versionSuffix given_path+        real_suf = versionSuffix real_path+        guessNormal dir = dir </> toolname <.> exeExtension buildPlatform+        guessGhcjs dir =+          dir+            </> (toolname ++ "-ghcjs")+              <.> exeExtension buildPlatform+        guessGhcjsVersioned dir suf =+          dir+            </> (toolname ++ "-ghcjs" ++ suf)+              <.> exeExtension buildPlatform+        guessVersioned dir suf =+          dir+            </> (toolname ++ suf)+              <.> exeExtension buildPlatform+        mkGuesses dir suf+          | null suf = [guessGhcjs dir, guessNormal dir]+          | otherwise =+              [ guessGhcjsVersioned dir suf+              , guessVersioned dir suf+              , guessGhcjs dir+              , guessNormal dir+              ]+        guesses =+          mkGuesses given_dir given_suf+            ++ if real_path == given_path+              then []+              else mkGuesses real_dir real_suf+    info verbosity $+      "looking for tool "+        ++ toolname+        ++ " near compiler in "+        ++ given_dir+    debug verbosity $ "candidate locations: " ++ show guesses+    exists <- traverse doesFileExist guesses+    case [file | (file, True) <- zip guesses exists] of+      -- If we can't find it near ghc, fall back to the usual+      -- method.+      [] -> programFindLocation tool verbosity searchpath+      (fp : _) -> do+        info verbosity $ "found " ++ toolname ++ " in " ++ fp+        let lookedAt =+              map fst+                . takeWhile (\(_file, exist) -> not exist)+                $ zip guesses exists+        return (Just (fp, lookedAt))+  where+    takeVersionSuffix :: FilePath -> String+    takeVersionSuffix = takeWhileEndLE isSuffixChar++    isSuffixChar :: Char -> Bool+    isSuffixChar c = isDigit c || c == '.' || c == '-'++getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]+getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg+  where+    version = fromMaybe (error "GHCJS.getGhcInfo: no version") $ programVersion ghcjsProg+    implInfo = ghcVersionImplInfo version++-- | Given a single package DB, return all installed packages.+getPackageDBContents+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBX (SymbolicPath from (Dir PkgDB))+  -> ProgramDb+  -> IO InstalledPackageIndex+getPackageDBContents verbosity mbWorkDir packagedb progdb = do+  pkgss <- getInstalledPackages' verbosity mbWorkDir [packagedb] progdb+  toPackageIndex verbosity pkgss progdb++-- | Given a package DB stack, return all installed packages.+getInstalledPackages+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBStackX (SymbolicPath from (Dir PkgDB))+  -> ProgramDb+  -> IO InstalledPackageIndex+getInstalledPackages verbosity mbWorkDir packagedbs progdb = do+  checkPackageDbEnvVar verbosity+  checkPackageDbStack verbosity packagedbs+  pkgss <- getInstalledPackages' verbosity mbWorkDir packagedbs progdb+  index <- toPackageIndex verbosity pkgss progdb+  return $! index++toPackageIndex+  :: Verbosity+  -> [(PackageDBX a, [InstalledPackageInfo])]+  -> ProgramDb+  -> IO InstalledPackageIndex+toPackageIndex verbosity pkgss progdb = do+  -- On Windows, various fields have $topdir/foo rather than full+  -- paths. We need to substitute the right value in so that when+  -- we, for example, call gcc, we have proper paths to give it.+  topDir <- getLibDir' verbosity ghcjsProg+  let indices =+        [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)+        | (_, pkgs) <- pkgss+        ]+  return $! (mconcat indices)+  where+    ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb++getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath+getLibDir verbosity lbi =+  dropWhileEndLE isSpace+    `fmap` getDbProgramOutput+      verbosity+      ghcjsProgram+      (withPrograms lbi)+      ["--print-libdir"]++getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath+getLibDir' verbosity ghcjsProg =+  dropWhileEndLE isSpace+    `fmap` getProgramOutput verbosity ghcjsProg ["--print-libdir"]++-- | Return the 'FilePath' to the global GHC package database.+getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath+getGlobalPackageDB verbosity ghcProg =+  dropWhileEndLE isSpace+    `fmap` getProgramOutput verbosity ghcProg ["--print-global-package-db"]++-- | Return the 'FilePath' to the per-user GHC package database.+getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath+getUserPackageDB _verbosity ghcjsProg platform = do+  -- It's rather annoying that we have to reconstruct this, because ghc+  -- hides this information from us otherwise. But for certain use cases+  -- like change monitoring it really can't remain hidden.+  appdir <- getAppUserDataDirectory "ghcjs"+  return (appdir </> platformAndVersion </> packageConfFileName)+  where+    platformAndVersion =+      Internal.ghcPlatformAndVersionString+        platform+        ghcjsVersion+    packageConfFileName = "package.conf.d"+    ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg++checkPackageDbEnvVar :: Verbosity -> IO ()+checkPackageDbEnvVar verbosity =+  Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH"++checkPackageDbStack :: Eq fp => Verbosity -> PackageDBStackX fp -> IO ()+checkPackageDbStack _ (GlobalPackageDB : rest)+  | GlobalPackageDB `notElem` rest = return ()+checkPackageDbStack verbosity rest+  | GlobalPackageDB `notElem` rest =+      dieWithException verbosity GlobalPackageDBLimitation+checkPackageDbStack verbosity _ =+  dieWithException verbosity GlobalPackageDBSpecifiedFirst++getInstalledPackages'+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir from))+  -> [PackageDBX (SymbolicPath from (Dir PkgDB))]+  -> ProgramDb+  -> IO [(PackageDBX (SymbolicPath from (Dir PkgDB)), [InstalledPackageInfo])]+getInstalledPackages' verbosity mbWorkDir packagedbs progdb =+  sequenceA+    [ do+      pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity mbWorkDir packagedb+      return (packagedb, pkgs)+    | packagedb <- packagedbs+    ]++-- | Get the packages from specific PackageDBs, not cumulative.+getInstalledPackagesMonitorFiles+  :: Verbosity+  -> Platform+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> ProgramDb+  -> [PackageDB]+  -> IO [FilePath]+getInstalledPackagesMonitorFiles verbosity platform mbWorkDir progdb =+  traverse getPackageDBPath+  where+    getPackageDBPath :: PackageDB -> IO FilePath+    getPackageDBPath GlobalPackageDB =+      selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg+    getPackageDBPath UserPackageDB =+      selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform+    getPackageDBPath (SpecificPackageDB path) = selectMonitorFile (interpretSymbolicPath mbWorkDir path)++    -- GHC has old style file dbs, and new style directory dbs.+    -- Note that for dir style dbs, we only need to monitor the cache file, not+    -- the whole directory. The ghc program itself only reads the cache file+    -- so it's safe to only monitor this one file.+    selectMonitorFile path0 = do+      let path =+            if isRelative path0+              then interpretSymbolicPath mbWorkDir (makeRelativePathEx path0)+              else path0+      isFileStyle <- doesFileExist path+      if isFileStyle+        then return path+        else return (path </> "package.cache")++    ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb++toJSLibName :: String -> String+toJSLibName lib+  | takeExtension lib `elem` [".dll", ".dylib", ".so"] =+      replaceExtension lib "js_so"+  | takeExtension lib == ".a" = replaceExtension lib "js_a"+  | otherwise = lib <.> "js_a"++-- -----------------------------------------------------------------------------+-- Building a library++buildLib+  :: Verbosity+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> Library+  -> ComponentLocalBuildInfo+  -> IO ()+buildLib = buildOrReplLib Nothing++replLib+  :: [String]+  -> Verbosity+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> Library+  -> ComponentLocalBuildInfo+  -> IO ()+replLib = buildOrReplLib . Just++buildOrReplLib+  :: Maybe [String]+  -> Verbosity+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> Library+  -> ComponentLocalBuildInfo+  -> IO ()+buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do+  let uid = componentUnitId clbi+      libTargetDir = componentBuildDir lbi clbi+      whenVanillaLib forceVanilla =+        when (forceVanilla || withVanillaLib lbi)+      whenProfLib = when (withProfLib lbi)+      whenSharedLib forceShared =+        when (forceShared || withSharedLib lbi)+      whenStaticLib forceStatic =+        when (forceStatic || withStaticLib lbi)+      -- whenGHCiLib = when (withGHCiLib lbi)+      forRepl = maybe False (const True) mReplFlags+      -- ifReplLib = when forRepl+      comp = compiler lbi+      implInfo = getImplInfo comp+      platform@(Platform _hostArch _hostOS) = hostPlatform lbi+      has_code = not (componentIsIndefinite clbi)+      mbWorkDir = mbWorkDirLBI lbi++      -- See Note [Symbolic paths] in Distribution.Utils.Path+      i = interpretSymbolicPathLBI lbi+      u :: SymbolicPathX allowAbs Pkg to -> FilePath+      u = getSymbolicPath++  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)+  let runGhcjsProg = runGHC verbosity ghcjsProg comp platform mbWorkDir++  let libBi = libBuildInfo lib++  -- fixme flags shouldn't depend on ghcjs being dynamic or not+  let isGhcjsDynamic = isDynamic comp+      dynamicTooSupported = supportsDynamicToo comp+      doingTH = usesTemplateHaskellOrQQ libBi+      forceVanillaLib = doingTH && not isGhcjsDynamic+      forceSharedLib = doingTH && isGhcjsDynamic+  -- TH always needs default libs, even when building for profiling++  -- Determine if program coverage should be enabled and if so, what+  -- '-hpcdir' should be.+  let isCoverageEnabled = libCoverage lbi+      hpcdir way+        | forRepl = mempty -- HPC is not supported in ghci+        | isCoverageEnabled = toFlag $ Hpc.mixDir (coerceSymbolicPath libTargetDir </> coerceSymbolicPath extraCompilationArtifacts) way+        | otherwise = mempty++  createDirectoryIfMissingVerbose verbosity True $ i libTargetDir+  -- TODO: do we need to put hs-boot files into place for mutually recursive+  -- modules?+  let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi)+      jsSrcs = jsSources libBi+      cObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cLikeFiles+      baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir+      linkJsLibOpts =+        mempty+          { ghcOptExtra =+              [ "-link-js-lib"+              , getHSLibraryName uid+              , "-js-lib-outputdir"+              , u libTargetDir+              ]+                ++ map u jsSrcs+          }+      vanillaOptsNoJsLib =+        baseOpts+          `mappend` mempty+            { ghcOptMode = toFlag GhcModeMake+            , ghcOptNumJobs = numJobs+            , ghcOptInputModules = toNubListR $ allLibModules lib clbi+            , ghcOptHPCDir = hpcdir Hpc.Vanilla+            }+      vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts++      profOpts =+        adjustExts "p_hi" "p_o" vanillaOpts+          `mappend` mempty+            { ghcOptProfilingMode = toFlag True+            , ghcOptProfilingAuto =+                Internal.profDetailLevelFlag+                  True+                  (withProfLibDetail lbi)+            , --  ghcOptHiSuffix      = toFlag "p_hi",+              --  ghcOptObjSuffix     = toFlag "p_o",+              ghcOptExtra = hcProfOptions GHC libBi+            , ghcOptHPCDir = hpcdir Hpc.Prof+            }++      sharedOpts =+        adjustExts "dyn_hi" "dyn_o" vanillaOpts+          `mappend` mempty+            { ghcOptDynLinkMode = toFlag GhcDynamicOnly+            , ghcOptFPic = toFlag True+            , --  ghcOptHiSuffix    = toFlag "dyn_hi",+              --  ghcOptObjSuffix   = toFlag "dyn_o",+              ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi+            , ghcOptHPCDir = hpcdir Hpc.Dyn+            }++      vanillaSharedOpts =+        vanillaOpts+          `mappend` mempty+            { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic+            , ghcOptDynHiSuffix = toFlag "js_dyn_hi"+            , ghcOptDynObjSuffix = toFlag "js_dyn_o"+            , ghcOptHPCDir = hpcdir Hpc.Dyn+            }++  unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $+    do+      let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts)+          shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts)+          useDynToo =+            dynamicTooSupported+              && (forceVanillaLib || withVanillaLib lbi)+              && (forceSharedLib || withSharedLib lbi)+              && null (hcSharedOptions GHC libBi)+      if not has_code+        then vanilla+        else+          if useDynToo+            then do+              runGhcjsProg vanillaSharedOpts+              case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of+                (Flag dynDir, Flag vanillaDir) ->+                  -- When the vanilla and shared library builds are done+                  -- in one pass, only one set of HPC module interfaces+                  -- are generated. This set should suffice for both+                  -- static and dynamically linked executables. We copy+                  -- the modules interfaces so they are available under+                  -- both ways.+                  copyDirectoryRecursive verbosity (i dynDir) (i vanillaDir)+                _ -> return ()+            else+              if isGhcjsDynamic+                then do shared; vanilla+                else do vanilla; shared+      whenProfLib (runGhcjsProg profOpts)++  -- Build any C++ sources separately.+  {-+    unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do+      info verbosity "Building C++ Sources..."+      sequence_+        [ do let baseCxxOpts    = Internal.componentCxxGhcOptions verbosity implInfo+                                  lbi libBi clbi libTargetDir filename+                 vanillaCxxOpts = if isGhcjsDynamic+                                  then baseCxxOpts { ghcOptFPic = toFlag True }+                                  else baseCxxOpts+                 profCxxOpts    = vanillaCxxOpts `mappend` mempty {+                                    ghcOptProfilingMode = toFlag True,+                                    ghcOptObjSuffix     = toFlag "p_o"+                                  }+                 sharedCxxOpts  = vanillaCxxOpts `mappend` mempty {+                                   ghcOptFPic        = toFlag True,+                                   ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                                   ghcOptObjSuffix   = toFlag "dyn_o"+                                 }+                 odir           = fromFlag (ghcOptObjDir vanillaCxxOpts)+             createDirectoryIfMissingVerbose verbosity True odir+             let runGhcProgIfNeeded cxxOpts = do+                   needsRecomp <- checkNeedsRecompilation filename cxxOpts+                   when needsRecomp $ runGhcjsProg cxxOpts+             runGhcProgIfNeeded vanillaCxxOpts+             unless forRepl $+               whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts)+             unless forRepl $ whenProfLib   (runGhcProgIfNeeded   profCxxOpts)+        | filename <- cxxSources libBi]++    ifReplLib $ do+      when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules"+      ifReplLib (runGhcjsProg replOpts)+  -}+  -- build any C sources+  -- TODO: Add support for S and CMM files.+  {-+    unless (not has_code || null (cSources libBi) || not nativeToo) $ do+      info verbosity "Building C Sources..."+      sequence_+        [ do let baseCcOpts    = Internal.componentCcGhcOptions verbosity implInfo+                                 lbi libBi clbi libTargetDir filename+                 vanillaCcOpts = if isGhcjsDynamic+                                 -- Dynamic GHC requires C sources to be built+                                 -- with -fPIC for REPL to work. See #2207.+                                 then baseCcOpts { ghcOptFPic = toFlag True }+                                 else baseCcOpts+                 profCcOpts    = vanillaCcOpts `mappend` mempty {+                                   ghcOptProfilingMode = toFlag True,+                                   ghcOptObjSuffix     = toFlag "p_o"+                                 }+                 sharedCcOpts  = vanillaCcOpts `mappend` mempty {+                                   ghcOptFPic        = toFlag True,+                                   ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                                   ghcOptObjSuffix   = toFlag "dyn_o"+                                 }+                 odir          = fromFlag (ghcOptObjDir vanillaCcOpts)+             createDirectoryIfMissingVerbose verbosity True odir+             let runGhcProgIfNeeded ccOpts = do+                   needsRecomp <- checkNeedsRecompilation filename ccOpts+                   when needsRecomp $ runGhcjsProg ccOpts+             runGhcProgIfNeeded vanillaCcOpts+             unless forRepl $+               whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts)+             unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts)+        | filename <- cSources libBi]+  -}+  -- TODO: problem here is we need the .c files built first, so we can load them+  -- with ghci, but .c files can depend on .h files generated by ghc by ffi+  -- exports.++  -- link:++  when has_code . when False {- fixme nativeToo -} . unless forRepl $ do+    info verbosity "Linking..."+    let cSharedObjs =+          map+            ((`replaceExtensionSymbolicPath` ("dyn_" ++ objExtension)))+            (cSources libBi ++ cxxSources libBi)+        compiler_id = compilerId (compiler lbi)+        sharedLibFilePath = libTargetDir </> makeRelativePathEx (mkSharedLibName (hostPlatform lbi) compiler_id uid)+        staticLibFilePath = libTargetDir </> makeRelativePathEx (mkStaticLibName (hostPlatform lbi) compiler_id uid)++    let stubObjs = []+        stubSharedObjs = []++    {-+        stubObjs <- catMaybes <$> sequenceA+          [ findFileWithExtension [objExtension] [libTargetDir]+              (ModuleName.toFilePath x ++"_stub")+          | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files+          , x <- allLibModules lib clbi ]+        stubProfObjs <- catMaybes <$> sequenceA+          [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]+              (ModuleName.toFilePath x ++"_stub")+          | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files+          , x <- allLibModules lib clbi ]+        stubSharedObjs <- catMaybes <$> sequenceA+          [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]+              (ModuleName.toFilePath x ++"_stub")+          | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files+          , x <- allLibModules lib clbi ]+    -}+    hObjs <-+      Internal.getHaskellObjects+        implInfo+        lib+        lbi+        clbi+        (coerceSymbolicPath libTargetDir)+        objExtension+        True+    hSharedObjs <-+      if withSharedLib lbi+        then+          Internal.getHaskellObjects+            implInfo+            lib+            lbi+            clbi+            (coerceSymbolicPath libTargetDir)+            ("dyn_" ++ objExtension)+            False+        else return []++    unless (null hObjs && null cObjs && null stubObjs) $ do+      rpaths <- getRPaths lbi clbi++      let staticObjectFiles =+            hObjs+              ++ map (makeSymbolicPath . (getSymbolicPath libTargetDir </>) . getSymbolicPath) cObjs+              ++ stubObjs+          dynamicObjectFiles =+            hSharedObjs+              ++ map (makeSymbolicPath . (getSymbolicPath libTargetDir </>) . getSymbolicPath) cSharedObjs+              ++ stubSharedObjs+          -- After the relocation lib is created we invoke ghc -shared+          -- with the dependencies spelled out as -package arguments+          -- and ghc invokes the linker with the proper library paths+          ghcSharedLinkArgs =+            mempty+              { ghcOptShared = toFlag True+              , ghcOptDynLinkMode = toFlag GhcDynamicOnly+              , ghcOptInputFiles = toNubListR dynamicObjectFiles+              , ghcOptOutputFile = toFlag sharedLibFilePath+              , ghcOptExtra = 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+              , ghcOptNoAutoLinkPackages = toFlag True+              , ghcOptPackageDBs = withPackageDB lbi+              , ghcOptThisUnitId = case clbi of+                  LibComponentLocalBuildInfo{componentCompatPackageKey = pk} ->+                    toFlag pk+                  _ -> mempty+              , ghcOptThisComponentId = case clbi of+                  LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->+                    if null insts+                      then mempty+                      else toFlag (componentComponentId clbi)+                  _ -> mempty+              , ghcOptInstantiatedWith = case clbi of+                  LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->+                    insts+                  _ -> []+              , ghcOptPackages =+                  toNubListR $+                    Internal.mkGhcOptPackages mempty clbi+              , ghcOptLinkLibs = extraLibs libBi+              , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi+              , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi+              , ghcOptLinkFrameworkDirs =+                  toNubListR $ PD.extraFrameworkDirs libBi+              , ghcOptRPaths = rpaths+              }+          ghcStaticLinkArgs =+            mempty+              { ghcOptStaticLib = toFlag True+              , ghcOptInputFiles = toNubListR staticObjectFiles+              , ghcOptOutputFile = toFlag staticLibFilePath+              , ghcOptExtra = hcStaticOptions GHC libBi+              , ghcOptHideAllPackages = toFlag True+              , ghcOptNoAutoLinkPackages = toFlag True+              , ghcOptPackageDBs = withPackageDB lbi+              , ghcOptThisUnitId = case clbi of+                  LibComponentLocalBuildInfo{componentCompatPackageKey = pk} ->+                    toFlag pk+                  _ -> mempty+              , ghcOptThisComponentId = case clbi of+                  LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->+                    if null insts+                      then mempty+                      else toFlag (componentComponentId clbi)+                  _ -> mempty+              , ghcOptInstantiatedWith = case clbi of+                  LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->+                    insts+                  _ -> []+              , ghcOptPackages =+                  toNubListR $+                    Internal.mkGhcOptPackages mempty clbi+              , ghcOptLinkLibs = extraLibs libBi+              , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi+              }++      info verbosity (show (ghcOptPackages ghcSharedLinkArgs))+      {-+            whenVanillaLib False $ do+              Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles+              whenGHCiLib $ do+                (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)+                Ld.combineObjectFiles verbosity lbi ldProg+                  ghciLibFilePath staticObjectFiles+                  -}+      {-+            whenProfLib $ do+              Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles+              whenGHCiLib $ do+                (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)+                Ld.combineObjectFiles verbosity lbi ldProg+                  ghciProfLibFilePath profObjectFiles+      -}+      whenSharedLib False $+        runGhcjsProg ghcSharedLinkArgs++      whenStaticLib False $+        runGhcjsProg ghcStaticLinkArgs++-- | Start a REPL without loading any source files.+startInterpreter+  :: Verbosity+  -> ProgramDb+  -> Compiler+  -> Platform+  -> PackageDBStack+  -> IO ()+startInterpreter verbosity progdb comp platform packageDBs = do+  let replOpts =+        mempty+          { ghcOptMode = toFlag GhcModeInteractive+          , ghcOptPackageDBs = packageDBs+          }+  checkPackageDbStack verbosity packageDBs+  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb+  runGHC verbosity ghcjsProg comp platform Nothing replOpts++-- -----------------------------------------------------------------------------+-- Building an executable or foreign library++-- | Build a foreign library+buildFLib+  :: Verbosity+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> ForeignLib+  -> ComponentLocalBuildInfo+  -> IO ()+buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib++replFLib+  :: [String]+  -> Verbosity+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> ForeignLib+  -> ComponentLocalBuildInfo+  -> IO ()+replFLib replFlags v njobs pkg lbi =+  gbuild v njobs pkg lbi . GReplFLib replFlags++-- | Build an executable with GHC.+buildExe+  :: Verbosity+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> Executable+  -> ComponentLocalBuildInfo+  -> IO ()+buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe++replExe+  :: [String]+  -> Verbosity+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> Executable+  -> ComponentLocalBuildInfo+  -> IO ()+replExe replFlags v njobs pkg lbi =+  gbuild v njobs pkg lbi . GReplExe replFlags++-- | Building an executable, starting the REPL, and building foreign+-- libraries are all very similar and implemented in 'gbuild'. The+-- 'GBuildMode' distinguishes between the various kinds of operation.+data GBuildMode+  = GBuildExe Executable+  | GReplExe [String] Executable+  | GBuildFLib ForeignLib+  | GReplFLib [String] ForeignLib++gbuildInfo :: GBuildMode -> BuildInfo+gbuildInfo (GBuildExe exe) = buildInfo exe+gbuildInfo (GReplExe _ exe) = buildInfo exe+gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib+gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib++gbuildName :: GBuildMode -> String+gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe+gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe+gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib+gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib++gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String+gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe+gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe+gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib+gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib++exeTargetName :: Platform -> Executable -> String+exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform++-- | Target name for a foreign library (the actual file name)+--+-- We do not use mkLibName and co here because the naming for foreign libraries+-- is slightly different (we don't use "_p" or compiler version suffices, and we+-- don't want the "lib" prefix on Windows).+--+-- TODO: We do use `dllExtension` and co here, but really that's wrong: they+-- use the OS used to build cabal to determine which extension to use, rather+-- than the target OS (but this is wrong elsewhere in Cabal as well).+flibTargetName :: LocalBuildInfo -> ForeignLib -> String+flibTargetName lbi flib =+  case (os, foreignLibType flib) of+    (Windows, ForeignLibNativeShared) -> nm <.> "dll"+    (Windows, ForeignLibNativeStatic) -> nm <.> "lib"+    (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt+    (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi)+    (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi)+    (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type"+  where+    nm :: String+    nm = unUnqualComponentName $ foreignLibName flib++    os :: OS+    os =+      let (Platform _ os') = hostPlatform lbi+       in os'++    -- If a foreign lib foo has lib-version-info 5:1:2 or+    -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1+    -- Libtool's version-info data is translated into library versions in a+    -- nontrivial way: so refer to libtool documentation.+    versionedExt :: String+    versionedExt =+      let nums = foreignLibVersion flib os+       in foldl (<.>) "so" (map show nums)++-- | Name for the library when building.+--+-- If the `lib-version-info` field or the `lib-version-linux` field of+-- a foreign library target is set, we need to incorporate that+-- version into the SONAME field.+--+-- If a foreign library foo has lib-version-info 5:1:2, it should be+-- built as libfoo.so.3.2.1.  We want it to get soname libfoo.so.3.+-- However, GHC does not allow overriding soname by setting linker+-- options, as it sets a soname of its own (namely the output+-- filename), after the user-supplied linker options.  Hence, we have+-- to compile the library with the soname as its filename.  We rename+-- the compiled binary afterwards.+--+-- This method allows to adjust the name of the library at build time+-- such that the correct soname can be set.+flibBuildName :: LocalBuildInfo -> ForeignLib -> String+flibBuildName lbi flib+  -- On linux, if a foreign-library has version data, the first digit is used+  -- to produce the SONAME.+  | (os, foreignLibType flib)+      == (Linux, ForeignLibNativeShared) =+      let nums = foreignLibVersion flib os+       in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums))+  | otherwise = flibTargetName lbi flib+  where+    os :: OS+    os =+      let (Platform _ os') = hostPlatform lbi+       in os'++    nm :: String+    nm = unUnqualComponentName $ foreignLibName flib++gbuildIsRepl :: GBuildMode -> Bool+gbuildIsRepl (GBuildExe _) = False+gbuildIsRepl (GReplExe _ _) = True+gbuildIsRepl (GBuildFLib _) = False+gbuildIsRepl (GReplFLib _ _) = True++gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool+gbuildNeedDynamic lbi bm =+  case bm of+    GBuildExe _ -> withDynExe lbi+    GReplExe _ _ -> withDynExe lbi+    GBuildFLib flib -> withDynFLib flib+    GReplFLib _ flib -> withDynFLib flib+  where+    withDynFLib flib =+      case foreignLibType flib of+        ForeignLibNativeShared ->+          ForeignLibStandalone `notElem` foreignLibOptions flib+        ForeignLibNativeStatic ->+          False+        ForeignLibTypeUnknown ->+          cabalBug "unknown foreign lib type"++gbuildModDefFiles :: GBuildMode -> [RelativePath Source File]+gbuildModDefFiles (GBuildExe _) = []+gbuildModDefFiles (GReplExe _ _) = []+gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib+gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib++-- | "Main" module name when overridden by @ghc-options: -main-is ...@+-- or 'Nothing' if no @-main-is@ flag could be found.+--+-- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed.+exeMainModuleName :: Executable -> Maybe ModuleName+exeMainModuleName Executable{buildInfo = bnfo} =+  -- GHC honors the last occurrence of a module name updated via -main-is+  --+  -- Moreover, -main-is when parsed left-to-right can update either+  -- the "Main" module name, or the "main" function name, or both,+  -- see also 'decodeMainIsArg'.+  msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts+  where+    ghcopts = hcOptions GHC bnfo++    findIsMainArgs [] = []+    findIsMainArgs ("-main-is" : arg : rest) = arg : findIsMainArgs rest+    findIsMainArgs (_ : rest) = findIsMainArgs rest++-- | Decode argument to '-main-is'+--+-- Returns 'Nothing' if argument set only the function name.+--+-- This code has been stolen/refactored from GHC's DynFlags.setMainIs+-- function. The logic here is deliberately imperfect as it is+-- intended to be bug-compatible with GHC's parser. See discussion in+-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753.+decodeMainIsArg :: String -> Maybe ModuleName+decodeMainIsArg arg+  | headOf main_fn isLower =+      -- The arg looked like "Foo.Bar.baz"+      Just (ModuleName.fromString main_mod)+  | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar"+    =+      Just (ModuleName.fromString arg)+  | otherwise -- The arg looked like "baz"+    =+      Nothing+  where+    headOf :: String -> (Char -> Bool) -> Bool+    headOf str pred' = any pred' (safeHead str)++    (main_mod, main_fn) = splitLongestPrefix arg (== '.')++    splitLongestPrefix :: String -> (Char -> Bool) -> (String, String)+    splitLongestPrefix str pred'+      | null r_pre = (str, [])+      | otherwise = (reverse (safeTail r_pre), reverse r_suf)+      where+        -- 'safeTail' drops the char satisfying 'pred'+        (r_suf, r_pre) = break pred' (reverse str)++-- | A collection of:+--    * C input files+--    * C++ input files+--    * GHC input files+--    * GHC input modules+--+-- Used to correctly build and link sources.+data BuildSources = BuildSources+  { cSourcesFiles :: [SymbolicPath Pkg File]+  , cxxSourceFiles :: [SymbolicPath Pkg File]+  , inputSourceFiles :: [SymbolicPath Pkg File]+  , inputSourceModules :: [ModuleName]+  }++-- | Locate and return the 'BuildSources' required to build and link.+gbuildSources+  :: Verbosity+  -> Maybe (SymbolicPath CWD ('Dir Pkg))+  -> PackageId+  -> CabalSpecVersion+  -> SymbolicPath Pkg (Dir Source)+  -> GBuildMode+  -> IO BuildSources+gbuildSources verbosity mbWorkDir pkgId specVer tmpDir bm =+  case bm of+    GBuildExe exe -> exeSources exe+    GReplExe _ exe -> exeSources exe+    GBuildFLib flib -> return $ flibSources flib+    GReplFLib _ flib -> return $ flibSources flib+  where+    exeSources :: Executable -> IO BuildSources+    exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do+      main <- findFileCwd verbosity mbWorkDir (tmpDir : hsSourceDirs bnfo) modPath+      let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe+          otherModNames = exeModules exe+          haskellMain = isHaskell (getSymbolicPath main)++      -- Scripts have fakePackageId and are always Haskell but can have any extension.+      if haskellMain || pkgId == fakePackageId+        then+          if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames)+            then do+              -- The cabal manual clearly states that `other-modules` is+              -- intended for non-main modules.  However, there's at least one+              -- important package on Hackage (happy-1.19.5) which+              -- violates this. We workaround this here so that we don't+              -- invoke GHC with e.g.  'ghc --make Main src/Main.hs' which+              -- would result in GHC complaining about duplicate Main+              -- modules.+              --+              -- Finally, we only enable this workaround for+              -- specVersion < 2, as 'cabal-version:>=2.0' cabal files+              -- have no excuse anymore to keep doing it wrong... ;-)+              warn verbosity $+                "Enabling workaround for Main module '"+                  ++ prettyShow mainModName+                  ++ "' listed in 'other-modules' illegally!"++              return+                BuildSources+                  { cSourcesFiles = cSources bnfo+                  , cxxSourceFiles = cxxSources bnfo+                  , inputSourceFiles = [main]+                  , inputSourceModules = filter (/= mainModName) $ exeModules exe+                  }+            else+              return+                BuildSources+                  { cSourcesFiles = cSources bnfo+                  , cxxSourceFiles = cxxSources bnfo+                  , inputSourceFiles = [main]+                  , inputSourceModules = exeModules exe+                  }+        else+          let (csf, cxxsf)+                | isCxx (getSymbolicPath main) = (cSources bnfo, main : cxxSources bnfo)+                -- if main is not a Haskell source+                -- and main is not a C++ source+                -- then we assume that it is a C source+                | otherwise = (main : cSources bnfo, cxxSources bnfo)+           in return+                BuildSources+                  { cSourcesFiles = csf+                  , cxxSourceFiles = cxxsf+                  , inputSourceFiles = []+                  , inputSourceModules = exeModules exe+                  }++    flibSources :: ForeignLib -> BuildSources+    flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} =+      BuildSources+        { cSourcesFiles = cSources bnfo+        , cxxSourceFiles = cxxSources bnfo+        , inputSourceFiles = []+        , inputSourceModules = foreignLibModules flib+        }++    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+  -> Flag ParStrat+  -> PackageDescription+  -> LocalBuildInfo+  -> GBuildMode+  -> ComponentLocalBuildInfo+  -> IO ()+gbuild verbosity numJobs pkg_descr lbi bm clbi = do+  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)+  let replFlags = case bm of+        GReplExe flags _ -> flags+        GReplFLib flags _ -> flags+        GBuildExe{} -> mempty+        GBuildFLib{} -> mempty+      comp = compiler lbi+      platform = hostPlatform lbi+      mbWorkDir = mbWorkDirLBI lbi+      runGhcProg = runGHC verbosity ghcjsProg comp platform mbWorkDir++  let (bnfo, threaded) = case bm of+        GBuildFLib _ -> popThreadedFlag (gbuildInfo bm)+        _ -> (gbuildInfo bm, False)++  -- the name that GHC really uses (e.g., with .exe on Windows for executables)+  let targetName = gbuildTargetName lbi bm+      targetDir = buildDir lbi </> makeRelativePathEx (gbuildName bm)+      tmpDir = targetDir </> makeRelativePathEx (gbuildName bm ++ "-tmp")++      -- See Note [Symbolic paths] in Distribution.Utils.Path+      i = interpretSymbolicPath mbWorkDir++  createDirectoryIfMissingVerbose verbosity True $ i targetDir+  createDirectoryIfMissingVerbose verbosity True $ i tmpDir++  -- TODO: do we need to put hs-boot files into place for mutually recursive+  -- modules?  FIX: what about exeName.hi-boot?++  -- Determine if program coverage should be enabled and if so, what+  -- '-hpcdir' should be.+  let isCoverageEnabled = exeCoverage lbi+      hpcdir way+        | gbuildIsRepl bm = mempty -- HPC is not supported in ghci+        | isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir </> coerceSymbolicPath extraCompilationArtifacts) way+        | otherwise = mempty++  rpaths <- getRPaths lbi clbi+  buildSources <- gbuildSources verbosity mbWorkDir (package pkg_descr) (specVersion pkg_descr) tmpDir bm++  let cSrcs = cSourcesFiles buildSources+      cxxSrcs = cxxSourceFiles buildSources+      inputFiles = inputSourceFiles buildSources+      inputModules = inputSourceModules buildSources+      isGhcDynamic = isDynamic comp+      dynamicTooSupported = supportsDynamicToo comp+      cObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cSrcs+      cxxObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cxxSrcs+      needDynamic = gbuildNeedDynamic lbi bm+      needProfiling = withProfExe lbi++      -- build executables+      buildRunner = case clbi of+        LibComponentLocalBuildInfo{} -> False+        FLibComponentLocalBuildInfo{} -> False+        ExeComponentLocalBuildInfo{} -> True+        TestComponentLocalBuildInfo{} -> True+        BenchComponentLocalBuildInfo{} -> True+      baseOpts =+        (componentGhcOptions verbosity lbi bnfo clbi tmpDir)+          `mappend` mempty+            { ghcOptMode = toFlag GhcModeMake+            , ghcOptInputFiles =+                toNubListR $+                  if package pkg_descr == fakePackageId+                    then filter (isHaskell . getSymbolicPath) inputFiles+                    else inputFiles+            , ghcOptInputScripts =+                toNubListR $+                  if package pkg_descr == fakePackageId+                    then filter (not . isHaskell . getSymbolicPath) inputFiles+                    else []+            , ghcOptInputModules = toNubListR inputModules+            , -- for all executable components (exe/test/bench),+              -- GHCJS must be passed the "-build-runner" option+              ghcOptExtra =+                if buildRunner+                  then ["-build-runner"]+                  else mempty+            }+      staticOpts =+        baseOpts+          `mappend` mempty+            { ghcOptDynLinkMode = toFlag GhcStaticOnly+            , ghcOptHPCDir = hpcdir Hpc.Vanilla+            }+      profOpts =+        baseOpts+          `mappend` mempty+            { ghcOptProfilingMode = toFlag True+            , ghcOptProfilingAuto =+                Internal.profDetailLevelFlag+                  False+                  (withProfExeDetail lbi)+            , ghcOptHiSuffix = toFlag "p_hi"+            , ghcOptObjSuffix = toFlag "p_o"+            , ghcOptExtra = hcProfOptions GHC bnfo+            , ghcOptHPCDir = hpcdir Hpc.Prof+            }+      dynOpts =+        baseOpts+          `mappend` mempty+            { ghcOptDynLinkMode = toFlag GhcDynamicOnly+            , -- TODO: Does it hurt to set -fPIC for executables?+              ghcOptFPic = toFlag True+            , ghcOptHiSuffix = toFlag "dyn_hi"+            , ghcOptObjSuffix = toFlag "dyn_o"+            , ghcOptExtra = hcOptions GHC bnfo ++ hcSharedOptions GHC bnfo+            , ghcOptHPCDir = hpcdir Hpc.Dyn+            }+      dynTooOpts =+        staticOpts+          `mappend` mempty+            { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic+            , ghcOptDynHiSuffix = toFlag "dyn_hi"+            , ghcOptDynObjSuffix = toFlag "dyn_o"+            , ghcOptHPCDir = hpcdir Hpc.Dyn+            }+      linkerOpts =+        mempty+          { ghcOptLinkOptions = PD.ldOptions bnfo+          , ghcOptLinkLibs = extraLibs bnfo+          , ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo+          , ghcOptLinkFrameworks =+              toNubListR $+                map getSymbolicPath $+                  PD.frameworks bnfo+          , ghcOptLinkFrameworkDirs =+              toNubListR $+                PD.extraFrameworkDirs bnfo+          , ghcOptInputFiles =+              toNubListR+                [makeSymbolicPath $ getSymbolicPath tmpDir </> getSymbolicPath x | x <- cObjs ++ cxxObjs]+          }+      dynLinkerOpts =+        mempty+          { ghcOptRPaths = rpaths+          }+      replOpts =+        baseOpts+          { ghcOptExtra =+              Internal.filterGhciFlags+                (ghcOptExtra baseOpts)+                <> replFlags+          }+          -- For a normal compile we do separate invocations of ghc for+          -- compiling as for linking. But for repl we have to do just+          -- the one invocation, so that one has to include all the+          -- linker stuff too, like -l flags and any .o files from C+          -- files etc.+          `mappend` linkerOpts+          `mappend` mempty+            { ghcOptMode = toFlag GhcModeInteractive+            , ghcOptOptimisation = toFlag GhcNoOptimisation+            }+      commonOpts+        | needProfiling = profOpts+        | needDynamic = dynOpts+        | otherwise = staticOpts+      compileOpts+        | useDynToo = dynTooOpts+        | otherwise = commonOpts+      withStaticExe = not needProfiling && not needDynamic++      -- For building exe's that use TH with -prof or -dynamic we actually have+      -- to build twice, once without -prof/-dynamic and then again with+      -- -prof/-dynamic. This is because the code that TH needs to run at+      -- compile time needs to be the vanilla ABI so it can be loaded up and run+      -- by the compiler.+      -- With dynamic-by-default GHC the TH object files loaded at compile-time+      -- need to be .dyn_o instead of .o.+      doingTH = usesTemplateHaskellOrQQ bnfo+      -- Should we use -dynamic-too instead of compiling twice?+      useDynToo =+        dynamicTooSupported+          && isGhcDynamic+          && doingTH+          && withStaticExe+          && null (hcSharedOptions GHC bnfo)+      compileTHOpts+        | isGhcDynamic = dynOpts+        | otherwise = staticOpts+      compileForTH+        | gbuildIsRepl bm = False+        | useDynToo = False+        | isGhcDynamic = doingTH && (needProfiling || withStaticExe)+        | otherwise = doingTH && (needProfiling || needDynamic)++  -- Build static/dynamic object files for TH, if needed.+  when compileForTH $+    runGhcProg+      compileTHOpts+        { ghcOptNoLink = toFlag True+        , ghcOptNumJobs = numJobs+        }++  -- Do not try to build anything if there are no input files.+  -- This can happen if the cabal file ends up with only cSrcs+  -- but no Haskell modules.+  unless+    ( (null inputFiles && null inputModules)+        || gbuildIsRepl bm+    )+    $ runGhcProg+      compileOpts+        { ghcOptNoLink = toFlag True+        , ghcOptNumJobs = numJobs+        }++  -- build any C++ sources+  unless (null cxxSrcs) $ do+    info verbosity "Building C++ Sources..."+    sequence_+      [ do+        let baseCxxOpts =+              Internal.componentCxxGhcOptions+                verbosity+                lbi+                bnfo+                clbi+                tmpDir+                filename+            vanillaCxxOpts =+              if isGhcDynamic+                then -- Dynamic GHC requires C++ sources to be built+                -- with -fPIC for REPL to work. See #2207.+                  baseCxxOpts{ghcOptFPic = toFlag True}+                else baseCxxOpts+            profCxxOpts =+              vanillaCxxOpts+                `mappend` mempty+                  { ghcOptProfilingMode = toFlag True+                  }+            sharedCxxOpts =+              vanillaCxxOpts+                `mappend` mempty+                  { ghcOptFPic = toFlag True+                  , ghcOptDynLinkMode = toFlag GhcDynamicOnly+                  }+            opts+              | needProfiling = profCxxOpts+              | needDynamic = sharedCxxOpts+              | otherwise = vanillaCxxOpts+            -- TODO: Placing all Haskell, C, & C++ objects in a single directory+            --       Has the potential for file collisions. In general we would+            --       consider this a user error. However, we should strive to+            --       add a warning if this occurs.+            odir = fromFlag (ghcOptObjDir opts)+        createDirectoryIfMissingVerbose verbosity True (i odir)+        needsRecomp <- checkNeedsRecompilation mbWorkDir filename opts+        when needsRecomp $+          runGhcProg opts+      | filename <- cxxSrcs+      ]++  -- build any C sources+  unless (null cSrcs) $ do+    info verbosity "Building C Sources..."+    sequence_+      [ do+        let baseCcOpts =+              Internal.componentCcGhcOptions+                verbosity+                lbi+                bnfo+                clbi+                tmpDir+                filename+            vanillaCcOpts =+              if isGhcDynamic+                then -- Dynamic GHC requires C sources to be built+                -- with -fPIC for REPL to work. See #2207.+                  baseCcOpts{ghcOptFPic = toFlag True}+                else baseCcOpts+            profCcOpts =+              vanillaCcOpts+                `mappend` mempty+                  { ghcOptProfilingMode = toFlag True+                  }+            sharedCcOpts =+              vanillaCcOpts+                `mappend` mempty+                  { ghcOptFPic = toFlag True+                  , ghcOptDynLinkMode = toFlag GhcDynamicOnly+                  }+            opts+              | needProfiling = profCcOpts+              | needDynamic = sharedCcOpts+              | otherwise = vanillaCcOpts+            odir = fromFlag (ghcOptObjDir opts)+        createDirectoryIfMissingVerbose verbosity True (i odir)+        needsRecomp <- checkNeedsRecompilation mbWorkDir filename opts+        when needsRecomp $+          runGhcProg opts+      | filename <- cSrcs+      ]++  -- TODO: problem here is we need the .c files built first, so we can load them+  -- with ghci, but .c files can depend on .h files generated by ghc by ffi+  -- exports.+  case bm of+    GReplExe _ _ -> runGhcProg replOpts+    GReplFLib _ _ -> runGhcProg replOpts+    GBuildExe _ -> do+      let linkOpts =+            commonOpts+              `mappend` linkerOpts+              `mappend` mempty+                { ghcOptLinkNoHsMain = toFlag (null inputFiles)+                }+              `mappend` (if withDynExe lbi then dynLinkerOpts else mempty)++      info verbosity "Linking..."+      -- Work around old GHCs not relinking in this+      -- situation, see #3294+      let target = targetDir </> 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+          rtsOptLinkLibs =+            [ if needDynamic+                then+                  if threaded+                    then dynRtsThreadedLib (rtsDynamicInfo rtsInfo)+                    else dynRtsVanillaLib (rtsDynamicInfo rtsInfo)+                else+                  if threaded+                    then statRtsThreadedLib (rtsStaticInfo rtsInfo)+                    else statRtsVanillaLib (rtsStaticInfo rtsInfo)+            ]+          linkOpts = case foreignLibType flib of+            ForeignLibNativeShared ->+              commonOpts+                `mappend` linkerOpts+                `mappend` dynLinkerOpts+                `mappend` mempty+                  { ghcOptLinkNoHsMain = toFlag True+                  , ghcOptShared = toFlag True+                  , ghcOptLinkLibs = rtsOptLinkLibs+                  , ghcOptLinkLibPath = toNubListR $ map makeSymbolicPath $ rtsLibPaths rtsInfo+                  , ghcOptFPic = toFlag True+                  , ghcOptLinkModDefFiles = toNubListR $ fmap getSymbolicPath $ gbuildModDefFiles bm+                  }+            ForeignLibNativeStatic ->+              -- this should be caught by buildFLib+              -- (and if we do implement this, we probably don't even want to call+              -- ghc here, but rather Ar.createArLibArchive or something)+              cabalBug "static libraries not yet implemented"+            ForeignLibTypeUnknown ->+              cabalBug "unknown foreign lib type"+      -- We build under a (potentially) different filename to set a+      -- soname on supported platforms.  See also the note for+      -- @flibBuildName@.+      info verbosity "Linking..."+      let buildName = flibBuildName lbi flib+          buildFile = targetDir </> makeRelativePathEx buildName+      runGhcProg linkOpts{ghcOptOutputFile = toFlag buildFile}+      renameFile (i buildFile) (i targetDir </> targetName)++data DynamicRtsInfo = DynamicRtsInfo+  { dynRtsVanillaLib :: FilePath+  , dynRtsThreadedLib :: FilePath+  , dynRtsDebugLib :: FilePath+  , dynRtsEventlogLib :: FilePath+  , dynRtsThreadedDebugLib :: FilePath+  , dynRtsThreadedEventlogLib :: FilePath+  }++data StaticRtsInfo = StaticRtsInfo+  { statRtsVanillaLib :: FilePath+  , statRtsThreadedLib :: FilePath+  , statRtsDebugLib :: FilePath+  , statRtsEventlogLib :: FilePath+  , statRtsThreadedDebugLib :: FilePath+  , statRtsThreadedEventlogLib :: FilePath+  , statRtsProfilingLib :: FilePath+  , statRtsThreadedProfilingLib :: FilePath+  }++data RtsInfo = RtsInfo+  { rtsDynamicInfo :: DynamicRtsInfo+  , rtsStaticInfo :: StaticRtsInfo+  , rtsLibPaths :: [FilePath]+  }++-- | Extract (and compute) information about the RTS library+--+-- TODO: This hardcodes the name as @HSrts-ghc<version>@. I don't know if we can+-- find this information somewhere. We can lookup the 'hsLibraries' field of+-- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which+-- doesn't really help.+extractRtsInfo :: LocalBuildInfo -> RtsInfo+extractRtsInfo lbi =+  case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of+    [(_, [rts])] -> aux rts+    _otherwise -> error "No (or multiple) ghc rts package is registered"+  where+    aux :: InstalledPackageInfo -> RtsInfo+    aux rts =+      RtsInfo+        { rtsDynamicInfo =+            DynamicRtsInfo+              { dynRtsVanillaLib = withGhcVersion "HSrts"+              , dynRtsThreadedLib = withGhcVersion "HSrts_thr"+              , dynRtsDebugLib = withGhcVersion "HSrts_debug"+              , dynRtsEventlogLib = withGhcVersion "HSrts_l"+              , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug"+              , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l"+              }+        , rtsStaticInfo =+            StaticRtsInfo+              { statRtsVanillaLib = "HSrts"+              , statRtsThreadedLib = "HSrts_thr"+              , statRtsDebugLib = "HSrts_debug"+              , statRtsEventlogLib = "HSrts_l"+              , statRtsThreadedDebugLib = "HSrts_thr_debug"+              , statRtsThreadedEventlogLib = "HSrts_thr_l"+              , statRtsProfilingLib = "HSrts_p"+              , statRtsThreadedProfilingLib = "HSrts_thr_p"+              }+        , rtsLibPaths = InstalledPackageInfo.libraryDirs rts+        }+    withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi))))++-- | Returns True if the modification date of the given source file is newer than+-- the object file we last compiled for it, or if no object file exists yet.+checkNeedsRecompilation+  :: Maybe (SymbolicPath CWD (Dir Pkg))+  -> SymbolicPath Pkg File+  -> GhcOptions+  -> IO Bool+checkNeedsRecompilation mbWorkDir filename opts =+  i filename `moreRecentFile` oname+  where+    oname = getObjectFileName mbWorkDir filename opts+    i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path++-- | Finds the object file name of the given source file+getObjectFileName+  :: Maybe (SymbolicPath CWD (Dir Pkg))+  -> SymbolicPath Pkg File+  -> GhcOptions+  -> FilePath+getObjectFileName mbWorkDir filename opts = oname+  where+    i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path+    odir = i $ 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++-- | Calculate the RPATHs for the component we are building.+--+-- Calculates relative RPATHs when 'relocatable' is set.+getRPaths+  :: LocalBuildInfo+  -> ComponentLocalBuildInfo+  -- ^ Component we are building+  -> IO (NubListR FilePath)+getRPaths lbi clbi | supportRPaths hostOS = do+  libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi+  let hostPref = case hostOS of+        OSX -> "@loader_path"+        _ -> "$ORIGIN"+      relPath p = if isRelative p then hostPref </> p else p+      rpaths = toNubListR (map relPath libraryPaths)+  return rpaths+  where+    (Platform _ hostOS) = hostPlatform lbi+    compid = compilerId . compiler $ lbi++    -- The list of RPath-supported operating systems below reflects the+    -- platforms on which Cabal's RPATH handling is tested. It does _NOT_+    -- reflect whether the OS supports RPATH.++    -- E.g. when this comment was written, the *BSD operating systems were+    -- untested with regards to Cabal RPATH handling, and were hence set to+    -- 'False', while those operating systems themselves do support RPATH.+    supportRPaths Linux = True+    supportRPaths Windows = False+    supportRPaths OSX = True+    supportRPaths FreeBSD =+      case compid of+        CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True+        _ -> False+    supportRPaths OpenBSD = False+    supportRPaths NetBSD = False+    supportRPaths DragonFly = False+    supportRPaths Solaris = False+    supportRPaths AIX = False+    supportRPaths HPUX = False+    supportRPaths IRIX = False+    supportRPaths HaLVM = False+    supportRPaths IOS = False+    supportRPaths Android = False+    supportRPaths Ghcjs = False+    supportRPaths Wasi = False+    supportRPaths Hurd = True+    supportRPaths Haiku = False+    supportRPaths (OtherOS _) = False+-- Do _not_ add a default case so that we get a warning here when a new OS+-- is added.++getRPaths _ _ = return mempty++-- | Remove the "-threaded" flag when building a foreign library, as it has no+--   effect when used with "-shared". Returns the updated 'BuildInfo', along+--   with whether or not the flag was present, so we can use it to link against+--   the appropriate RTS on our own.+popThreadedFlag :: BuildInfo -> (BuildInfo, Bool)+popThreadedFlag bi =+  ( bi{options = filterHcOptions (/= "-threaded") (options bi)}+  , hasThreaded (options bi)+  )+  where+    filterHcOptions+      :: (String -> Bool)+      -> PerCompilerFlavor [String]+      -> PerCompilerFlavor [String]+    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+  :: Verbosity+  -> PackageDescription+  -> LocalBuildInfo+  -> Library+  -> ComponentLocalBuildInfo+  -> IO String+libAbiHash verbosity _pkg_descr lbi lib clbi = do+  let+    libBi = libBuildInfo lib+    comp = compiler lbi+    platform = hostPlatform lbi+    mbWorkDir = mbWorkDirLBI lbi+    vanillaArgs =+      (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi))+        `mappend` mempty+          { ghcOptMode = toFlag GhcModeAbiHash+          , ghcOptInputModules = toNubListR $ exposedModules lib+          }+    sharedArgs =+      vanillaArgs+        `mappend` mempty+          { ghcOptDynLinkMode = toFlag GhcDynamicOnly+          , ghcOptFPic = toFlag True+          , ghcOptHiSuffix = toFlag "js_dyn_hi"+          , ghcOptObjSuffix = toFlag "js_dyn_o"+          , ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi+          }+    profArgs =+      vanillaArgs+        `mappend` mempty+          { ghcOptProfilingMode = toFlag True+          , ghcOptProfilingAuto =+              Internal.profDetailLevelFlag+                True+                (withProfLibDetail lbi)+          , ghcOptHiSuffix = toFlag "js_p_hi"+          , ghcOptObjSuffix = toFlag "js_p_o"+          , ghcOptExtra = hcProfOptions GHC libBi+          }+    ghcArgs+      | withVanillaLib lbi = vanillaArgs+      | withSharedLib lbi = sharedArgs+      | withProfLib lbi = profArgs+      | otherwise = error "libAbiHash: Can't find an enabled library way"++  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)+  hash <-+    getProgramInvocationOutput+      verbosity+      =<< ghcInvocation verbosity ghcjsProg comp platform mbWorkDir ghcArgs+  return (takeWhile (not . isSpace) hash)++componentGhcOptions+  :: Verbosity+  -> LocalBuildInfo+  -> BuildInfo+  -> ComponentLocalBuildInfo+  -> SymbolicPath Pkg (Dir build)+  -> GhcOptions+componentGhcOptions verbosity lbi bi clbi odir =+  let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir+   in opts+        { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi+        }++-- -----------------------------------------------------------------------------+-- Installing++-- | Install executables for GHCJS.+installExe+  :: Verbosity+  -> LocalBuildInfo+  -> FilePath+  -- ^ Where to copy the files to+  -> FilePath+  -- ^ Build location+  -> (FilePath, FilePath)+  -- ^ Executable (prefix,suffix)+  -> PackageDescription+  -> Executable+  -> IO ()+installExe+  verbosity+  lbi+  binDir+  buildPref+  (progprefix, progsuffix)+  _pkg+  exe = do+    createDirectoryIfMissingVerbose verbosity True binDir+    let exeName' = unUnqualComponentName $ exeName exe+        exeFileName = exeName'+        fixedExeBaseName = progprefix ++ exeName' ++ progsuffix+        installBinary dest = do+          runDbProgramCwd verbosity (mbWorkDirLBI lbi) ghcjsProgram (withPrograms lbi) $+            [ "--install-executable"+            , buildPref </> exeName' </> exeFileName+            , "-o"+            , dest+            ]+              ++ case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of+                (True, Just strip) -> ["-strip-program", programPath strip]+                _ -> []+    installBinary (binDir </> fixedExeBaseName)++-- | Install foreign library for GHC.+installFLib+  :: Verbosity+  -> LocalBuildInfo+  -> FilePath+  -- ^ install location+  -> FilePath+  -- ^ Build location+  -> PackageDescription+  -> ForeignLib+  -> IO ()+installFLib verbosity lbi targetDir builtDir _pkg flib =+  install+    (foreignLibIsShared flib)+    builtDir+    targetDir+    (flibTargetName lbi flib)+  where+    install _isShared srcDir dstDir name = do+      let src = srcDir </> name+          dst = dstDir </> name+      createDirectoryIfMissingVerbose verbosity True targetDir+      installOrdinaryFile verbosity src dst++-- | Install for ghc, .hi, .a and, if --with-ghci given, .o+installLib+  :: Verbosity+  -> LocalBuildInfo+  -> FilePath+  -- ^ install location+  -> FilePath+  -- ^ install location for dynamic libraries+  -> FilePath+  -- ^ Build location+  -> PackageDescription+  -> Library+  -> ComponentLocalBuildInfo+  -> IO ()+installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do+  whenVanilla $ copyModuleFiles $ Suffix "js_hi"+  whenProf $ copyModuleFiles $ Suffix "js_p_hi"+  whenShared $ copyModuleFiles $ Suffix "js_dyn_hi"++  -- whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName+  -- whenProf    $ installOrdinary builtDir targetDir $ toJSLibName profileLibName+  -- whenShared  $ installShared   builtDir dynlibTargetDir $ toJSLibName sharedLibName+  -- fixme do these make the correct lib names?+  whenHasCode $ do+    whenVanilla $ do+      sequence_+        [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f))+        | l <- getHSLibraryName (componentUnitId clbi) : (extraBundledLibs (libBuildInfo lib))+        , f <- "" : extraLibFlavours (libBuildInfo lib)+        ]+    -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName)+    whenProf $ do+      installOrdinary builtDir' targetDir (toJSLibName profileLibName)+    -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName)+    whenShared $+      sequence_+        [ installShared+          builtDir'+          dynlibTargetDir+          (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f))+        | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib)+        , f <- "" : extraDynLibFlavours (libBuildInfo lib)+        ]+  where+    i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path+    builtDir' = componentBuildDir lbi clbi+    mbWorkDir = mbWorkDirLBI lbi++    install isShared isJS srcDir dstDir name = do+      let src = i $ srcDir </> makeRelativePathEx name+          dst = dstDir </> name+      createDirectoryIfMissingVerbose verbosity True dstDir++      if isShared+        then installExecutableFile verbosity src dst+        else installOrdinaryFile verbosity src dst++      when (stripLibs lbi && not isJS) $+        Strip.stripLib+          verbosity+          (hostPlatform lbi)+          (withPrograms lbi)+          dst++    installOrdinary = install False True+    installShared = install True True++    copyModuleFiles ext = do+      files <- findModuleFilesCwd verbosity mbWorkDir [builtDir'] [ext] (allLibModules lib clbi)+      let files' = map (i *** getSymbolicPath) files+      installOrdinaryFiles verbosity targetDir files'++    compiler_id = compilerId (compiler lbi)+    platform = hostPlatform lbi+    uid = componentUnitId clbi+    -- vanillaLibName = mkLibName              uid+    profileLibName = mkProfLibName uid+    -- sharedLibName  = (mkSharedLibName (hostPlatform lbi) compiler_id)  uid++    hasLib =+      not $+        null (allLibModules lib clbi)+          && null (cSources (libBuildInfo lib))+          && null (cxxSources (libBuildInfo lib))+          && null (jsSources (libBuildInfo lib))+    has_code = not (componentIsIndefinite clbi)+    whenHasCode = when has_code+    whenVanilla = when (hasLib && withVanillaLib lbi)+    whenProf = when (hasLib && withProfLib lbi && has_code)+    -- whenGHCi    = when (hasLib && withGHCiLib    lbi && has_code)+    whenShared = when (hasLib && withSharedLib lbi && has_code)++adjustExts :: String -> String -> GhcOptions -> GhcOptions+adjustExts hiSuf objSuf opts =+  opts+    `mappend` mempty+      { ghcOptHiSuffix = toFlag hiSuf+      , ghcOptObjSuffix = toFlag objSuf+      }++isDynamic :: Compiler -> Bool+isDynamic = Internal.ghcLookupProperty "GHC Dynamic"++supportsDynamicToo :: Compiler -> Bool+supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"++withExt :: FilePath -> String -> FilePath+withExt fp ext = fp <.> if takeExtension fp /= ('.' : ext) then ext else ""++findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version)+findGhcjsGhcVersion verbosity pgm =+  findProgramVersion "--numeric-ghc-version" id verbosity pgm++findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version)+findGhcjsPkgGhcjsVersion verbosity pgm =+  findProgramVersion "--numeric-ghcjs-version" id verbosity pgm++-- -----------------------------------------------------------------------------+-- Registering++hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo+hcPkgInfo progdb =+  HcPkg.HcPkgInfo+    { HcPkg.hcPkgProgram = ghcjsPkgProg+    , HcPkg.noPkgDbStack = False+    , HcPkg.noVerboseFlag = False+    , HcPkg.flagPackageConf = False+    , HcPkg.supportsDirDbs = True+    , HcPkg.requiresDirDbs = ver >= v7_10+    , HcPkg.nativeMultiInstance = ver >= v7_10+    , HcPkg.recacheMultiInstance = True+    , HcPkg.suppressFilesCheck = True+    }+  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++registerPackage+  :: Verbosity+  -> ProgramDb+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBStackS from+  -> InstalledPackageInfo+  -> HcPkg.RegisterOptions+  -> IO ()+registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions =+  HcPkg.register+    (hcPkgInfo progdb)+    verbosity+    mbWorkDir+    packageDbs+    installedPkgInfo+    registerOptions++pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath+pkgRoot verbosity lbi = pkgRoot'+  where+    pkgRoot' GlobalPackageDB =+      let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi)+       in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg)+    pkgRoot' UserPackageDB = do+      appDir <- getAppUserDataDirectory "ghcjs"+      -- fixme correct this version+      let ver = compilerVersion (compiler lbi)+          subdir =+            System.Info.arch+              ++ '-'+              : System.Info.os+              ++ '-'+              : prettyShow ver+          rootDir = appDir </> subdir+      -- We must create the root directory for the user package database if it+      -- does not yet exists. Otherwise '${pkgroot}' will resolve to a+      -- directory at the time of 'ghc-pkg register', and registration will+      -- fail.+      createDirectoryIfMissing True rootDir+      return rootDir+    pkgRoot' (SpecificPackageDB fp) =+      return $+        takeDirectory $+          interpretSymbolicPathLBI lbi fp++-- | Get the JavaScript file name and command and arguments to run a+--   program compiled by GHCJS+--   the exe should be the base program name without exe extension+runCmd+  :: ProgramDb+  -> FilePath+  -> (FilePath, FilePath, [String]) runCmd progdb exe =   ( script   , programPath ghcjsProg
src/Distribution/Simple/Glob.hs view
@@ -1,8 +1,10 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Glob -- Copyright   :  Isaac Jones, Simon Marlow 2003-2004@@ -13,246 +15,333 @@ -- Portability :  portable -- -- Simple file globbing.+module Distribution.Simple.Glob+  ( -- * Globs+    Glob -module Distribution.Simple.Glob (-        GlobSyntaxError(..),-        GlobResult(..),-        matchDirFileGlob,-        matchDirFileGlobWithDie,-        runDirFileGlob,-        fileGlobMatches,-        parseFileGlob,-        explainGlobSyntaxError,-        Glob,-  ) where+    -- * Matching on globs+  , GlobResult (..)+  , globMatches+  , fileGlobMatches+  , matchGlob+  , matchGlobPieces+  , matchDirFileGlob+  , matchDirFileGlobWithDie+  , runDirFileGlob -import Prelude ()+    -- * Parsing globs+  , parseFileGlob+  , GlobSyntaxError (..)+  , explainGlobSyntaxError++    -- * Utility+  , isRecursiveInRoot+  )+where+ import Distribution.Compat.Prelude+import Prelude ()  import Distribution.CabalSpecVersion+  ( CabalSpecVersion (..)+  )+import Distribution.Pretty+import Distribution.Simple.Errors+  ( CabalException (MatchDirFileGlob, MatchDirFileGlobErrors)+  )+import Distribution.Simple.Glob.Internal import Distribution.Simple.Utils+  ( debug+  , dieWithException+  , getDirectoryContentsRecursive+  , warn+  )+import Distribution.Utils.Path import Distribution.Verbosity+  ( Verbosity+  , silent+  ) -import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist)-import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (</>), (<.>))+import Control.Monad (mapM)+import Data.List (stripPrefix)+import System.Directory+import System.FilePath hiding ((<.>), (</>)) -import qualified Data.List.NonEmpty as NE+------------------------------------------------------------------------------- --- Note throughout that we use splitDirectories, not splitPath. On--- Posix, this makes no difference, but, because Windows accepts both--- slash and backslash as its path separators, if we left in the--- separators from the glob we might not end up properly normalised.+-- * Matching -data GlobResult a-  = GlobMatch a-    -- ^ The glob matched the value supplied.-  | GlobWarnMultiDot a-    -- ^ The glob did not match the value supplied because the-    --   cabal-version is too low and the extensions on the file did-    --   not precisely match the glob's extensions, but rather the-    --   glob was a proper suffix of the file's extensions; i.e., if-    --   not for the low cabal-version, it would have matched.-  | GlobMissingDirectory FilePath-    -- ^ The glob couldn't match because the directory named doesn't-    --   exist. The directory will be as it appears in the glob (i.e.,-    --   relative to the directory passed to 'matchDirFileGlob', and,-    --   for 'data-files', relative to 'data-dir').-  deriving (Show, Eq, Ord, Functor)+-------------------------------------------------------------------------------- +-- | Match a 'Glob' against the file system, starting from a+-- given root directory. The results are all relative to the given root.+--+-- @since 3.12.0.0+matchGlob :: FilePath -> Glob -> IO [FilePath]+matchGlob root glob =+  -- For this function, which is the general globbing one (doesn't care about+  -- cabal spec, used e.g. for monitoring), we consider all matches.+  mapMaybe+    ( \case+        GlobMatch a -> Just a+        GlobWarnMultiDot a -> Just a+        GlobMatchesDirectory a -> Just a+        GlobMissingDirectory{} -> Nothing+    )+    <$> runDirFileGlob silent Nothing root glob++-- | Match a globbing pattern against a file path component+matchGlobPieces :: GlobPieces -> String -> Bool+matchGlobPieces = goStart+  where+    -- From the man page, glob(7):+    --   "If a filename starts with a '.', this character must be+    --    matched explicitly."++    go, goStart :: [GlobPiece] -> String -> Bool++    goStart (WildCard : _) ('.' : _) = False+    goStart (Union globs : rest) cs =+      any+        (\glob -> goStart (glob ++ rest) cs)+        globs+    goStart rest cs = go rest cs++    go [] "" = True+    go (Literal lit : rest) cs+      | Just cs' <- stripPrefix lit cs =+          go rest cs'+      | otherwise = False+    go [WildCard] "" = True+    go (WildCard : rest) (c : cs) = go rest (c : cs) || go (WildCard : rest) cs+    go (Union globs : rest) cs = any (\glob -> go (glob ++ rest) cs) globs+    go [] (_ : _) = False+    go (_ : _) "" = False+ -- | Extract the matches from a list of 'GlobResult's. -- -- Note: throws away the 'GlobMissingDirectory' results; chances are -- that you want to check for these and error out if any are present.+--+-- @since 3.12.0.0 globMatches :: [GlobResult a] -> [a]-globMatches input = [ a | GlobMatch a <- input ]--data GlobSyntaxError-  = StarInDirectory-  | StarInFileName-  | StarInExtension-  | NoExtensionOnStar-  | EmptyGlob-  | LiteralFileNameGlobStar-  | VersionDoesNotSupportGlobStar-  | VersionDoesNotSupportGlob-  deriving (Eq, Show)+globMatches input = [a | GlobMatch a <- input] -explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String-explainGlobSyntaxError filepath StarInDirectory =-     "invalid file glob '" ++ filepath-  ++ "'. A wildcard '**' is only allowed as the final parent"-  ++ " directory. Stars must not otherwise appear in the parent"-  ++ " directories."-explainGlobSyntaxError filepath StarInExtension =-     "invalid file glob '" ++ filepath-  ++ "'. Wildcards '*' are only allowed as the"-  ++ " file's base name, not in the file extension."-explainGlobSyntaxError filepath StarInFileName =-     "invalid file glob '" ++ filepath-  ++ "'. Wildcards '*' may only totally replace the"-  ++ " file's base name, not only parts of it."-explainGlobSyntaxError filepath NoExtensionOnStar =-     "invalid file glob '" ++ filepath-  ++ "'. If a wildcard '*' is used it must be with an file extension."-explainGlobSyntaxError filepath LiteralFileNameGlobStar =-     "invalid file glob '" ++ filepath-  ++ "'. If a wildcard '**' is used as a parent directory, the"-  ++ " file's base name must be a wildcard '*'."-explainGlobSyntaxError _ EmptyGlob =-     "invalid file glob. A glob cannot be the empty string."-explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar =-     "invalid file glob '" ++ filepath-  ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'"-  ++ " or greater. Alternatively, for compatibility with earlier Cabal"-  ++ " versions, list the included directories explicitly."-explainGlobSyntaxError filepath VersionDoesNotSupportGlob =-     "invalid file glob '" ++ filepath-  ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. "-  ++ "Alternatively if you require compatibility with earlier Cabal "-  ++ "versions then list all the files explicitly."+-- | This will 'die'' when the glob matches no files, or if the glob+-- refers to a missing directory, or if the glob fails to parse.+--+-- The 'Version' argument must be the spec version of the package+-- description being processed, as globs behave slightly differently+-- in different spec versions.+--+-- The first 'FilePath' argument is the directory that the glob is+-- relative to. It must be a valid directory (and hence it can't be+-- the empty string). The returned values will not include this+-- prefix.+--+-- The second 'FilePath' is the glob itself.+matchDirFileGlob+  :: Verbosity+  -> CabalSpecVersion+  -> Maybe (SymbolicPath CWD (Dir dir))+  -> SymbolicPathX allowAbs dir file+  -> IO [SymbolicPathX allowAbs dir file]+matchDirFileGlob v = matchDirFileGlobWithDie v dieWithException -data IsRecursive = Recursive | NonRecursive+-- | Like 'matchDirFileGlob' but with customizable 'die'+--+-- @since 3.6.0.0+matchDirFileGlobWithDie+  :: Verbosity+  -> (forall res. Verbosity -> CabalException -> IO [res])+  -> CabalSpecVersion+  -> Maybe (SymbolicPath CWD (Dir dir))+  -> SymbolicPathX allowAbs dir file+  -> IO [SymbolicPathX allowAbs dir file]+matchDirFileGlobWithDie verbosity rip version mbWorkDir symPath =+  let rawFilePath = getSymbolicPath symPath+      dir = maybe "." getSymbolicPath mbWorkDir+   in case parseFileGlob version rawFilePath of+        Left err -> rip verbosity $ MatchDirFileGlob (explainGlobSyntaxError rawFilePath err)+        Right glob -> do+          results <- runDirFileGlob verbosity (Just version) dir glob+          let missingDirectories =+                [missingDir | GlobMissingDirectory missingDir <- results]+              matches = globMatches results+              directoryMatches = [a | GlobMatchesDirectory a <- results] -data MultiDot = MultiDotDisabled | MultiDotEnabled+          let errors :: [String]+              errors =+                [ "filepath wildcard '"+                  ++ rawFilePath+                  ++ "' refers to the directory"+                  ++ " '"+                  ++ missingDir+                  ++ "', which does not exist or is not a directory."+                | missingDir <- missingDirectories+                ]+                  ++ [ "filepath wildcard '" ++ rawFilePath ++ "' does not match any files."+                     | null matches && null directoryMatches+                     -- we don't error out on directory matches, simply warn about them and ignore.+                     ] -data Glob-  = GlobStem FilePath Glob-    -- ^ A single subdirectory component + remainder.-  | GlobFinal GlobFinal+              warns :: [String]+              warns =+                [ "Ignoring directory '" ++ path ++ "'" ++ " listed in a Cabal package field which should only include files (not directories)."+                | path <- directoryMatches+                ] -data GlobFinal-  = FinalMatch IsRecursive MultiDot String-    -- ^ First argument: Is this a @**/*.ext@ pattern?-    --   Second argument: should we match against the exact extensions, or accept a suffix?-    --   Third argument: the extensions to accept.-  | FinalLit FilePath-    -- ^ Literal file name.+          if null errors+            then do+              unless (null warns) $+                warn verbosity $+                  unlines warns+              return $ map unsafeMakeSymbolicPath matches+            else rip verbosity $ MatchDirFileGlobErrors errors -reconstructGlob :: Glob -> FilePath-reconstructGlob (GlobStem dir glob) =-  dir </> reconstructGlob glob-reconstructGlob (GlobFinal final) = case final of-  FinalMatch Recursive _ exts -> "**" </> "*" <.> exts-  FinalMatch NonRecursive _ exts -> "*" <.> exts-  FinalLit path -> path+------------------------------------------------------------------------------- --- | Returns 'Nothing' if the glob didn't match at all, or 'Just' the---   result if the glob matched (or would have matched with a higher---   cabal-version).-fileGlobMatches :: Glob -> FilePath -> Maybe (GlobResult FilePath)-fileGlobMatches pat candidate = do-  match <- fileGlobMatchesSegments pat (splitDirectories candidate)-  return (candidate <$ match)+-- * Parsing & printing -fileGlobMatchesSegments :: Glob -> [FilePath] -> Maybe (GlobResult ())-fileGlobMatchesSegments _ [] = Nothing-fileGlobMatchesSegments pat (seg : segs) = case pat of-  GlobStem dir pat' -> do-    guard (dir == seg)-    fileGlobMatchesSegments pat' segs-  GlobFinal final -> case final of-    FinalMatch Recursive multidot ext -> do-      let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg:|segs)-      guard (not (null candidateBase))-      checkExt multidot ext candidateExts-    FinalMatch NonRecursive multidot ext -> do-      let (candidateBase, candidateExts) = splitExtensions seg-      guard (null segs && not (null candidateBase))-      checkExt multidot ext candidateExts-    FinalLit filename -> do-      guard (null segs && filename == seg)-      return (GlobMatch ())+--------------------------------------------------------------------------------+-- Filepaths with globs may be parsed in the special context is globbing in+-- cabal package fields, such as `data-files`. In that case, we restrict the+-- globbing syntax to that supported by the cabal spec version in use.+-- Otherwise, we parse the globs to the extent of our globbing features+-- (wildcards `*`, unions `{a,b,c}`, and directory-recursive wildcards `**`). -checkExt-  :: MultiDot-  -> String -- ^ The pattern's extension-  -> String -- ^ The candidate file's extension-  -> Maybe (GlobResult ())-checkExt multidot ext candidate-  | ext == candidate = Just (GlobMatch ())-  | ext `isSuffixOf` candidate = case multidot of-      MultiDotDisabled -> Just (GlobWarnMultiDot ())-      MultiDotEnabled -> Just (GlobMatch ())-  | otherwise = Nothing+-- ** Parsing globs in a cabal package  parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob parseFileGlob version filepath = case reverse (splitDirectories filepath) of   [] ->-        Left EmptyGlob+    Left EmptyGlob   (filename : "**" : segments)     | allowGlobStar -> do-        ext <- case splitExtensions filename of-          ("*", ext) | '*' `elem` ext -> Left StarInExtension-                     | null ext       -> Left NoExtensionOnStar-                     | otherwise      -> Right ext-          _                           -> Left LiteralFileNameGlobStar-        foldM addStem (GlobFinal $ FinalMatch Recursive multidot ext) segments+        finalSegment <- case splitExtensions filename of+          ("*", ext)+            | '*' `elem` ext -> Left StarInExtension+            | null ext -> Left NoExtensionOnStar+            | otherwise -> Right (GlobDirRecursive [WildCard, Literal ext])+          _+            | allowLiteralFilenameGlobStar ->+                Right (GlobDirRecursive [Literal filename])+            | otherwise ->+                Left LiteralFileNameGlobStar++        foldM addStem finalSegment segments     | otherwise -> Left VersionDoesNotSupportGlobStar   (filename : segments) -> do-        pat <- case splitExtensions filename of-          ("*", ext) | not allowGlob       -> Left VersionDoesNotSupportGlob-                     | '*' `elem` ext      -> Left StarInExtension-                     | null ext            -> Left NoExtensionOnStar-                     | otherwise           -> Right (FinalMatch NonRecursive multidot ext)-          (_, ext)   | '*' `elem` ext      -> Left StarInExtension-                     | '*' `elem` filename -> Left StarInFileName-                     | otherwise           -> Right (FinalLit filename)-        foldM addStem (GlobFinal pat) segments+    pat <- case splitExtensions filename of+      ("*", ext)+        | not allowGlob -> Left VersionDoesNotSupportGlob+        | '*' `elem` ext -> Left StarInExtension+        | null ext -> Left NoExtensionOnStar+        | otherwise -> Right (GlobFile [WildCard, Literal ext])+      (_, ext)+        | '*' `elem` ext -> Left StarInExtension+        | '*' `elem` filename -> Left StarInFileName+        | otherwise -> Right (GlobFile [Literal filename])++    foldM addStem pat segments   where-    allowGlob     = version >= CabalSpecV1_6-    allowGlobStar = version >= CabalSpecV2_4     addStem pat seg       | '*' `elem` seg = Left StarInDirectory-      | otherwise      = Right (GlobStem seg pat)-    multidot-      | version >= CabalSpecV2_4 = MultiDotEnabled-      | otherwise                = MultiDotDisabled+      | otherwise = Right (GlobDir [Literal seg] pat)+    allowGlob = version >= CabalSpecV1_6+    allowGlobStar = version >= CabalSpecV2_4+    allowLiteralFilenameGlobStar = version >= CabalSpecV3_8 --- | This will 'die'' when the glob matches no files, or if the glob--- refers to a missing directory, or if the glob fails to parse.------ The 'Version' argument must be the spec version of the package--- description being processed, as globs behave slightly differently--- in different spec versions.------ The first 'FilePath' argument is the directory that the glob is--- relative to. It must be a valid directory (and hence it can't be--- the empty string). The returned values will not include this--- prefix.------ The second 'FilePath' is the glob itself.----matchDirFileGlob :: Verbosity -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath]-matchDirFileGlob v = matchDirFileGlobWithDie v die'+enableMultidot :: CabalSpecVersion -> Bool+enableMultidot version+  | version >= CabalSpecV2_4 = True+  | otherwise = False --- | Like 'matchDirFileGlob' but with customizable 'die'------ @since 3.6.0.0----matchDirFileGlobWithDie :: Verbosity -> (Verbosity -> String -> IO [FilePath]) -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath]-matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob version filepath of-  Left err -> rip verbosity $ explainGlobSyntaxError filepath err-  Right glob -> do-    results <- runDirFileGlob verbosity dir glob-    let missingDirectories =-          [ missingDir | GlobMissingDirectory missingDir <- results ]-        matches = globMatches results+--------------------------------------------------------------------------------+-- Parse and printing utils+-------------------------------------------------------------------------------- -    let errors :: [String]-        errors =-            [ "filepath wildcard '" ++ filepath ++ "' refers to the directory"-            ++ " '" ++ missingDir ++ "', which does not exist or is not a directory."-            | missingDir <- missingDirectories-            ]-            ++-            [ "filepath wildcard '" ++ filepath ++ "' does not match any files."-            | null matches-            ]+-- ** Cabal package globbing errors -    if null errors-    then return matches-    else rip verbosity $ unlines errors+data GlobSyntaxError+  = StarInDirectory+  | StarInFileName+  | StarInExtension+  | NoExtensionOnStar+  | EmptyGlob+  | LiteralFileNameGlobStar+  | VersionDoesNotSupportGlobStar+  | VersionDoesNotSupportGlob+  deriving (Eq, Show) +explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String+explainGlobSyntaxError filepath StarInDirectory =+  "invalid file glob '"+    ++ filepath+    ++ "'. A wildcard '**' is only allowed as the final parent"+    ++ " directory. Stars must not otherwise appear in the parent"+    ++ " directories."+explainGlobSyntaxError filepath StarInExtension =+  "invalid file glob '"+    ++ filepath+    ++ "'. Wildcards '*' are only allowed as the"+    ++ " file's base name, not in the file extension."+explainGlobSyntaxError filepath StarInFileName =+  "invalid file glob '"+    ++ filepath+    ++ "'. Wildcards '*' may only totally replace the"+    ++ " file's base name, not only parts of it."+explainGlobSyntaxError filepath NoExtensionOnStar =+  "invalid file glob '"+    ++ filepath+    ++ "'. If a wildcard '*' is used it must be with an file extension."+explainGlobSyntaxError filepath LiteralFileNameGlobStar =+  "invalid file glob '"+    ++ filepath+    ++ "'. Prior to 'cabal-version: 3.8'"+    ++ " if a wildcard '**' is used as a parent directory, the"+    ++ " file's base name must be a wildcard '*'."+explainGlobSyntaxError _ EmptyGlob =+  "invalid file glob. A glob cannot be the empty string."+explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar =+  "invalid file glob '"+    ++ filepath+    ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'"+    ++ " or greater. Alternatively, for compatibility with earlier Cabal"+    ++ " versions, list the included directories explicitly."+explainGlobSyntaxError filepath VersionDoesNotSupportGlob =+  "invalid file glob '"+    ++ filepath+    ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. "+    ++ "Alternatively if you require compatibility with earlier Cabal "+    ++ "versions then list all the files explicitly."++-- Note throughout that we use splitDirectories, not splitPath. On+-- Posix, this makes no difference, but, because Windows accepts both+-- slash and backslash as its path separators, if we left in the+-- separators from the glob we might not end up properly normalised.++data GlobResult a+  = -- | The glob matched the value supplied.+    GlobMatch a+  | -- | The glob did not match the value supplied because the+    --   cabal-version is too low and the extensions on the file did+    --   not precisely match the glob's extensions, but rather the+    --   glob was a proper suffix of the file's extensions; i.e., if+    --   not for the low cabal-version, it would have matched.+    GlobWarnMultiDot a+  | -- | The glob couldn't match because the directory named doesn't+    --   exist. The directory will be as it appears in the glob (i.e.,+    --   relative to the directory passed to 'matchDirFileGlob', and,+    --   for 'data-files', relative to 'data-dir').+    GlobMissingDirectory a+  | -- | The glob matched a directory when we were looking for files only.+    -- It didn't match a file!+    --+    -- @since 3.12.0.0+    GlobMatchesDirectory a+  deriving (Show, Eq, Ord, Functor)+ -- | Match files against a pre-parsed glob, starting in a directory. -- -- The 'Version' argument must be the spec version of the package@@ -262,18 +351,24 @@ -- The 'FilePath' argument is the directory that the glob is relative -- to. It must be a valid directory (and hence it can't be the empty -- string). The returned values will not include this prefix.-runDirFileGlob :: Verbosity -> FilePath -> Glob -> IO [GlobResult FilePath]-runDirFileGlob verbosity rawDir pat = do+runDirFileGlob+  :: Verbosity+  -> Maybe CabalSpecVersion+  -- ^ If the glob we are running should care about the cabal spec, and warnings such as 'GlobWarnMultiDot', then this should be the version.+  -- If you want to run a glob but don't care about any of the cabal-spec restrictions on globs, use 'Nothing'!+  -> FilePath+  -> Glob+  -> IO [GlobResult FilePath]+runDirFileGlob verbosity mspec rawRoot pat = do   -- The default data-dir is null. Our callers -should- be   -- converting that to '.' themselves, but it's a certainty that   -- some future call-site will forget and trigger a really   -- hard-to-debug failure if we don't check for that here.-  when (null rawDir) $+  when (null rawRoot) $     warn verbosity $-         "Null dir passed to runDirFileGlob; interpreting it "-      ++ "as '.'. This is probably an internal error."-  let dir = if null rawDir then "." else rawDir-  debug verbosity $ "Expanding glob '" ++ reconstructGlob pat ++ "' in directory '" ++ dir ++ "'."+      "Null dir passed to runDirFileGlob; interpreting it "+        ++ "as '.'. This is probably an internal error."+  let root = if null rawRoot then "." else rawRoot   -- This function might be called from the project root with dir as   -- ".". Walking the tree starting there involves going into .git/   -- and dist-newstyle/, which is a lot of work for no reward, so@@ -281,40 +376,147 @@   -- there, and only walk as much as we need to: recursively if **,   -- the whole directory if *, and just the specific file if it's a   -- literal.-  let (prefixSegments, final) = splitConstantPrefix pat-      joinedPrefix = joinPath prefixSegments-  case final of-    FinalMatch recursive multidot exts -> do-      let prefix = dir </> joinedPrefix-      directoryExists <- doesDirectoryExist prefix+  let+    (prefixSegments, pathOrVariablePattern) = splitConstantPrefix pat+    joinedPrefix = joinPath prefixSegments++    -- The glob matching function depends on whether we care about the cabal version or not+    doesGlobMatch :: GlobPieces -> String -> Maybe (GlobResult ())+    doesGlobMatch glob str = case mspec of+      Just spec -> checkNameMatches spec glob str+      Nothing -> if matchGlobPieces glob str then Just (GlobMatch ()) else Nothing++    go (GlobFile glob) dir = do+      entries <- getDirectoryContents (root </> dir)+      catMaybes+        <$> mapM+          ( \s -> do+              -- When running a glob from a Cabal package description (i.e.+              -- when a cabal spec version is passed as an argument), we+              -- disallow matching a @GlobFile@ against a directory, preferring+              -- @GlobDir dir GlobDirTrailing@ to specify a directory match.+              isFile <- maybe (return True) (const $ doesFileExist (root </> dir </> s)) mspec+              let match = (dir </> s <$) <$> doesGlobMatch glob s+              return $+                if isFile+                  then match+                  else case match of+                    Just (GlobMatch x) -> Just $ GlobMatchesDirectory x+                    Just (GlobWarnMultiDot x) -> Just $ GlobMatchesDirectory x+                    Just (GlobMatchesDirectory x) -> Just $ GlobMatchesDirectory x+                    Just (GlobMissingDirectory x) -> Just $ GlobMissingDirectory x -- this should never match, unless you are in a file-delete-heavy concurrent setting i guess+                    Nothing -> Nothing+          )+          entries+    go (GlobDirRecursive glob) dir = do+      entries <- getDirectoryContentsRecursive (root </> dir)+      return $+        mapMaybe+          ( \s -> do+              globMatch <- doesGlobMatch glob (takeFileName s)+              pure ((dir </> s) <$ globMatch)+          )+          entries+    go (GlobDir glob globPath) dir = do+      entries <- getDirectoryContents (root </> dir)+      subdirs <-+        filterM+          ( \subdir ->+              doesDirectoryExist+                (root </> dir </> subdir)+          )+          $ filter (matchGlobPieces glob) entries+      concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs+    go GlobDirTrailing dir = return [GlobMatch dir]++  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 do-          candidates <- case recursive of-            Recursive -> getDirectoryContentsRecursive prefix-            NonRecursive -> filterM (doesFileExist . (prefix </>)) =<< getDirectoryContents prefix-          let checkName candidate = do-                let (candidateBase, candidateExts) = splitExtensions $ takeFileName candidate-                guard (not (null candidateBase))-                match <- checkExt multidot exts candidateExts-                return (joinedPrefix </> candidate <$ match)-          return $ mapMaybe checkName candidates-        else-          return [ GlobMissingDirectory joinedPrefix ]-    FinalLit fn -> do-      exists <- doesFileExist (dir </> joinedPrefix </> fn)-      return [ GlobMatch (joinedPrefix </> fn) | exists ]+        then pure [GlobMatchesDirectory filepath]+        else do+          exist <- doesFileExist (root </> filepath)+          pure $+            if exist+              then [GlobMatch filepath]+              else []+    Right variablePattern -> do+      debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'."+      directoryExists <- doesDirectoryExist (root </> joinedPrefix)+      if directoryExists+        then go variablePattern joinedPrefix+        else return [GlobMissingDirectory joinedPrefix]+  where+    -- \| Extract the (possibly null) constant prefix from the pattern.+    -- This has the property that, if @(pref, final) = splitConstantPrefix pat@,+    -- then @pat === foldr GlobDir final pref@.+    splitConstantPrefix :: Glob -> ([FilePath], Either FilePath Glob)+    splitConstantPrefix = fmap literalize . unfoldr' step+      where+        literalize (GlobFile [Literal filename]) =+          Left filename+        literalize glob =+          Right glob -unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r)-unfoldr' f a = case f a of-  Left r -> ([], r)-  Right (b, a') -> case unfoldr' f a' of-    (bs, r) -> (b : bs, r)+        step (GlobDir [Literal seg] pat') = Right (seg, pat')+        step pat' = Left pat' --- | Extract the (possibly null) constant prefix from the pattern.--- This has the property that, if @(pref, final) = splitConstantPrefix pat@,--- then @pat === foldr GlobStem (GlobFinal final) pref@.-splitConstantPrefix :: Glob -> ([FilePath], GlobFinal)-splitConstantPrefix = unfoldr' step+        unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r)+        unfoldr' f a = case f a of+          Left r -> ([], r)+          Right (b, a') -> case unfoldr' f a' of+            (bs, r) -> (b : bs, r)++-- | Is the root of this relative glob path a directory-recursive wildcard, e.g. @**/*.txt@ ?+isRecursiveInRoot :: Glob -> Bool+isRecursiveInRoot (GlobDirRecursive _) = True+isRecursiveInRoot _ = False++-- | Check how the string matches the glob under this cabal version+checkNameMatches :: CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ())+checkNameMatches spec glob candidate+  -- Check if glob matches in its general form+  | matchGlobPieces glob candidate =+      -- if multidot is supported, then this is a clean match+      if enableMultidot spec+        then pure (GlobMatch ())+        else -- if not, issue a warning saying multidot is needed for the match++          let (_, candidateExts) = splitExtensions $ takeFileName candidate+              extractExts :: GlobPieces -> Maybe String+              extractExts [] = Nothing+              extractExts [Literal lit]+                -- Any literal terminating a glob, and which does have an extension,+                -- returns that extension. Otherwise, recurse until Nothing is returned.+                | let ext = takeExtensions lit+                , ext /= "" =+                    Just ext+              extractExts (_ : x) = extractExts x+           in case extractExts glob of+                Just exts+                  | exts == candidateExts ->+                      return (GlobMatch ())+                  | exts `isSuffixOf` candidateExts ->+                      return (GlobWarnMultiDot ())+                _ -> return (GlobMatch ())+  | otherwise = empty++-- | How/does the glob match the given filepath, according to the cabal version?+-- Since this is pure, we don't make a distinction between matching on+-- directories or files (i.e. this function won't return 'GlobMatchesDirectory')+fileGlobMatches :: CabalSpecVersion -> Glob -> FilePath -> Maybe (GlobResult ())+fileGlobMatches version g path = go g (splitDirectories path)   where-    step (GlobStem seg pat) = Right (seg, pat)-    step (GlobFinal pat) = Left pat+    go GlobDirTrailing [] = Just (GlobMatch ())+    go (GlobFile glob) [file] = checkNameMatches version glob file+    go (GlobDirRecursive glob) dirs+      | [] <- reverse dirs =+          Nothing -- @dir/**/x.txt@ should not match @dir/hello@+      | file : _ <- reverse dirs =+          checkNameMatches version glob file+    go (GlobDir glob globPath) (dir : dirs) = do+      _ <- checkNameMatches version glob dir -- we only care if dir segment matches+      go globPath dirs+    go _ _ = Nothing
+ src/Distribution/Simple/Glob/Internal.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE DeriveGeneric #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Glob.Internal+-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004+-- License     :  BSD3+--                portions Copyright (c) 2007, Galois Inc.+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Internal module for simple file globbing.+-- Please import "Distribution.Simple.Glob" instead.+module Distribution.Simple.Glob.Internal where++import Distribution.Compat.Prelude+import Prelude ()++import qualified Distribution.Compat.CharParsing as P+import Distribution.Parsec+import Distribution.Pretty+import qualified Text.PrettyPrint as Disp++--------------------------------------------------------------------------------++-- | A filepath specified by globbing.+data Glob+  = -- | @<dirGlob>/<glob>@+    GlobDir !GlobPieces !Glob+  | -- | @**/<glob>@, where @**@ denotes recursively traversing+    -- all directories and matching filenames on <glob>.+    GlobDirRecursive !GlobPieces+  | -- | A file glob.+    GlobFile !GlobPieces+  | -- | Trailing dir; a glob ending in @/@.+    GlobDirTrailing+  deriving (Eq, Show, Generic)++instance Binary Glob+instance Structured Glob++-- | A single directory or file component of a globbed path+type GlobPieces = [GlobPiece]++-- | A piece of a globbing pattern+data GlobPiece+  = -- | A wildcard @*@+    WildCard+  | -- | A literal string @dirABC@+    Literal String+  | -- | A union of patterns, e.g. @dir/{a,*.txt,c}/...@+    Union [GlobPieces]+  deriving (Eq, Show, Generic)++instance Binary GlobPiece+instance Structured GlobPiece++--------------------------------------------------------------------------------+-- Parsing & pretty-printing++instance Pretty Glob where+  pretty (GlobDir glob pathglob) =+    dispGlobPieces glob+      Disp.<> Disp.char '/'+      Disp.<> pretty pathglob+  pretty (GlobDirRecursive glob) =+    Disp.text "**/"+      Disp.<> dispGlobPieces glob+  pretty (GlobFile glob) = dispGlobPieces glob+  pretty GlobDirTrailing = Disp.empty++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 '/'+          <|> P.try+            ( do+                _ <- P.char '\\'+                -- check this isn't an escape code+                P.notFollowedBy (P.satisfy isGlobEscapedChar)+            )++      parsecGlob :: CabalParsing m => m GlobPieces+      parsecGlob = some parsecPiece+        where+          parsecPiece = P.choice [literal, wildcard, union]++          wildcard = WildCard <$ P.char '*'+          union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ','))+          literal = Literal <$> some litchar++          litchar = normal <|> escape++          normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\')+          escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar++dispGlobPieces :: GlobPieces -> Disp.Doc+dispGlobPieces = Disp.hcat . map dispPiece+  where+    dispPiece WildCard = Disp.char '*'+    dispPiece (Literal str) = Disp.text (escape str)+    dispPiece (Union globs) =+      Disp.braces+        ( Disp.hcat+            ( Disp.punctuate+                (Disp.char ',')+                (map dispGlobPieces globs)+            )+        )+    escape [] = []+    escape (c : cs)+      | isGlobEscapedChar c = '\\' : c : escape cs+      | otherwise = c : escape cs++isGlobEscapedChar :: Char -> Bool+isGlobEscapedChar '*' = True+isGlobEscapedChar '{' = True+isGlobEscapedChar '}' = True+isGlobEscapedChar ',' = True+isGlobEscapedChar _ = False
src/Distribution/Simple/Haddock.hs view
@@ -1,926 +1,1634 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Haddock--- Copyright   :  Isaac Jones 2003-2005--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module deals with the @haddock@ and @hscolour@ commands.--- It uses information about installed packages (from @ghc-pkg@) to find the--- locations of documentation for dependent packages, so it can create links.------ The @hscolour@ support allows generating HTML versions of the original--- source, with coloured syntax highlighting.--module Distribution.Simple.Haddock (-  haddock, hscolour,--  haddockPackagePaths-  ) where--import Prelude ()-import Distribution.Compat.Prelude--import qualified Distribution.Simple.GHC   as GHC-import qualified Distribution.Simple.GHCJS as GHCJS---- local-import Distribution.Backpack.DescribeUnitId-import Distribution.Backpack (OpenModule)-import Distribution.Types.ForeignLib-import Distribution.Types.UnqualComponentName-import Distribution.Types.ComponentLocalBuildInfo-import Distribution.Types.ExecutableScope-import Distribution.Types.LocalBuildInfo-import Distribution.Types.TargetInfo-import Distribution.Types.ExposedModule-import Distribution.Package-import qualified Distribution.ModuleName as ModuleName-import Distribution.PackageDescription-import Distribution.Simple.Compiler-import Distribution.Simple.Glob-import Distribution.Simple.Program.GHC-import Distribution.Simple.Program.ResponseFile-import Distribution.Simple.Program-import Distribution.Simple.PreProcess-import Distribution.Simple.Setup-import Distribution.Simple.Build-import Distribution.Simple.BuildTarget-import Distribution.Simple.InstallDirs-import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate)-import Distribution.Simple.BuildPaths-import Distribution.Simple.Register-import qualified Distribution.Simple.Program.HcPkg as HcPkg-import qualified Distribution.Simple.PackageIndex as PackageIndex-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-import Distribution.InstalledPackageInfo ( InstalledPackageInfo )-import Distribution.Simple.Utils-import Distribution.System-import Distribution.Pretty-import Distribution.Parsec (simpleParsec)-import Distribution.Utils.NubList-import Distribution.Version-import qualified Distribution.Utils.ShortText as ShortText--import Distribution.Verbosity-import Language.Haskell.Extension--import Distribution.Compat.Semigroup (All (..), Any (..))--import Control.Monad-import Data.Either      ( rights )--import System.Directory (getCurrentDirectory, doesDirectoryExist, doesFileExist)-import System.FilePath  ( (</>), (<.>), normalise, isAbsolute )-import System.IO        (hClose, hPutStrLn, hSetEncoding, utf8)---- --------------------------------------------------------------------------------- Types---- | A record that represents the arguments to the haddock executable, a product--- monoid.-data HaddockArgs = HaddockArgs {- argInterfaceFile :: Flag FilePath,- -- ^ Path to the interface file, relative to argOutputDir, required.- argPackageName :: Flag PackageIdentifier,- -- ^ Package name, required.- argHideModules :: (All,[ModuleName.ModuleName]),- -- ^ (Hide modules ?, modules to hide)- argIgnoreExports :: Any,- -- ^ Ignore export lists in modules?- argLinkSource :: Flag (Template,Template,Template),- -- ^ (Template for modules, template for symbols, template for lines).- argLinkedSource :: Flag Bool,- -- ^ Generate hyperlinked sources- argQuickJump :: Flag Bool,- -- ^ Generate quickjump index- argCssFile :: Flag FilePath,- -- ^ Optional custom CSS file.- argContents :: Flag String,- -- ^ Optional URL to contents page.- argVerbose :: Any,- argOutput :: Flag [Output],- -- ^ HTML or Hoogle doc or both? Required.- argInterfaces :: [(FilePath, Maybe String, Maybe String)],- -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)].- argOutputDir :: Directory,- -- ^ Where to generate the documentation.- argTitle :: Flag String,- -- ^ Page title, required.- argPrologue :: Flag String,- -- ^ Prologue text, required.- argGhcOptions :: GhcOptions,- -- ^ Additional flags to pass to GHC.- argGhcLibDir :: Flag FilePath,- -- ^ To find the correct GHC, required.- argReexports :: [OpenModule],- -- ^ Re-exported modules- argTargets :: [FilePath]- -- ^ Modules to process.-} deriving Generic---- | The FilePath of a directory, it's a monoid under '(</>)'.-newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord)--unDir :: Directory -> FilePath-unDir = normalise . unDir'--type Template = String--data Output = Html | Hoogle---- --------------------------------------------------------------------------------- Haddock support--haddock :: PackageDescription-        -> LocalBuildInfo-        -> [PPSuffixHandler]-        -> HaddockFlags-        -> IO ()-haddock pkg_descr _ _ haddockFlags-  |    not (hasLibs pkg_descr)-    && not (fromFlag $ haddockExecutables haddockFlags)-    && not (fromFlag $ haddockTestSuites  haddockFlags)-    && not (fromFlag $ haddockBenchmarks  haddockFlags)-    && not (fromFlag $ haddockForeignLibs haddockFlags)-    =-      warn (fromFlag $ haddockVerbosity haddockFlags) $-           "No documentation was generated as this package does not contain "-        ++ "a library. Perhaps you want to use the --executables, --tests,"-        ++ " --benchmarks or --foreign-libraries flags."--haddock pkg_descr lbi suffixes flags' = do-    let verbosity     = flag haddockVerbosity-        comp          = compiler lbi-        platform      = hostPlatform lbi--        quickJmpFlag  = haddockQuickJump flags'-        flags = case haddockTarget of-          ForDevelopment -> flags'-          ForHackage -> flags'-            { haddockHoogle       = Flag True-            , haddockHtml         = Flag True-            , haddockHtmlLocation = Flag (pkg_url ++ "/docs")-            , haddockContents     = Flag (toPathTemplate pkg_url)-            , haddockLinkedSource = Flag True-            , haddockQuickJump    = Flag True-            }-        pkg_url       = "/package/$pkg-$version"-        flag f        = fromFlag $ f flags--        tmpFileOpts   = defaultTempFileOptions-                       { optKeepTempFiles = flag haddockKeepTempFiles }-        htmlTemplate  = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation-                        $ flags-        haddockTarget =-          fromFlagOrDefault ForDevelopment (haddockForHackage flags')--    (haddockProg, version, _) <--      requireProgramVersion verbosity haddockProgram-        (orLaterVersion (mkVersion [2,0])) (withPrograms lbi)--    -- various sanity checks-    when (flag haddockHoogle && version < mkVersion [2,2]) $-      die' verbosity "Haddock 2.0 and 2.1 do not support the --hoogle flag."---    when (flag haddockQuickJump && version < mkVersion [2,19]) $ do-      let msg = "Haddock prior to 2.19 does not support the --quickjump flag."-          alt = "The generated documentation won't have the QuickJump feature."-      if Flag True == quickJmpFlag-        then die' verbosity msg-        else warn verbosity (msg ++ "\n" ++ alt)--    haddockGhcVersionStr <- getProgramOutput verbosity haddockProg-                              ["--ghc-version"]-    case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of-      (Nothing, _) -> die' verbosity "Could not get GHC version from Haddock"-      (_, Nothing) -> die' verbosity "Could not get GHC version from compiler"-      (Just haddockGhcVersion, Just ghcVersion)-        | haddockGhcVersion == ghcVersion -> return ()-        | otherwise -> die' verbosity $-               "Haddock's internal GHC version must match the configured "-            ++ "GHC version.\n"-            ++ "The GHC version is " ++ prettyShow ghcVersion ++ " but "-            ++ "haddock is using GHC version " ++ prettyShow haddockGhcVersion--    -- the tools match the requests, we can proceed--    -- We fall back to using HsColour only for versions of Haddock which don't-    -- support '--hyperlinked-sources'.-    when (flag haddockLinkedSource && version < mkVersion [2,17]) $-      hscolour' (warn verbosity) haddockTarget pkg_descr lbi suffixes-      (defaultHscolourFlags `mappend` haddockToHscolour flags)--    libdirArgs <- getGhcLibDir  verbosity lbi-    let commonArgs = mconcat-            [ libdirArgs-            , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags-            , fromPackageDescription haddockTarget pkg_descr ]--    targets <- readTargetInfos verbosity pkg_descr lbi (haddockArgs flags)--    let-      targets' =-        case targets of-          [] -> allTargetsInBuildOrder' pkg_descr lbi-          _  -> targets--    internalPackageDB <--      createInternalPackageDB verbosity lbi (flag haddockDistPref)--    (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do--      let component = targetComponent target-          clbi      = targetCLBI target--      componentInitialBuildSteps (flag haddockDistPref) pkg_descr lbi clbi verbosity--      let-        lbi' = lbi {-          withPackageDB = withPackageDB lbi ++ [internalPackageDB],-          installedPkgs = index-          }--      preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes-      let-        doExe com = case (compToExe com) of-          Just exe -> do-            withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $-              \tmp -> do-                exeArgs <- fromExecutable verbosity tmp lbi' clbi htmlTemplate-                             version exe-                let exeArgs' = commonArgs `mappend` exeArgs-                runHaddock verbosity tmpFileOpts comp platform-                  haddockProg exeArgs'-          Nothing -> do-           warn (fromFlag $ haddockVerbosity flags)-             "Unsupported component, skipping..."-           return ()-        -- We define 'smsg' once and then reuse it inside the case, so that-        -- we don't say we are running Haddock when we actually aren't-        -- (e.g., Haddock is not run on non-libraries)-        smsg :: IO ()-        smsg = setupMessage' verbosity "Running Haddock on" (packageId pkg_descr)-                (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)-      case component of-        CLib lib -> do-          withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $-            \tmp -> do-              smsg-              libArgs <- fromLibrary verbosity tmp lbi' clbi htmlTemplate-                           version lib-              let libArgs' = commonArgs `mappend` libArgs-              runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs'--              case libName lib of-                LMainLibName ->-                  pure index-                LSubLibName _ -> do-                  pwd <- getCurrentDirectory--                  let-                    ipi = inplaceInstalledPackageInfo-                            pwd (flag haddockDistPref) pkg_descr-                            (mkAbiHash "inplace") lib lbi' clbi--                  debug verbosity $ "Registering inplace:\n"-                    ++ (InstalledPackageInfo.showInstalledPackageInfo ipi)--                  registerPackage verbosity (compiler lbi') (withPrograms lbi')-                    (withPackageDB lbi') ipi-                    HcPkg.defaultRegisterOptions {-                      HcPkg.registerMultiInstance = True-                    }--                  return $ PackageIndex.insert ipi index--        CFLib flib -> (when (flag haddockForeignLibs) $ do-          withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $-            \tmp -> do-              smsg-              flibArgs <- fromForeignLib verbosity tmp lbi' clbi htmlTemplate-                            version flib-              let libArgs' = commonArgs `mappend` flibArgs-              runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs')--          >> return index--        CExe   _ -> (when (flag haddockExecutables) $ smsg >> doExe component) >> return index-        CTest  _ -> (when (flag haddockTestSuites)  $ smsg >> doExe component) >> return index-        CBench _ -> (when (flag haddockBenchmarks)  $ smsg >> doExe component) >> return index--    for_ (extraDocFiles pkg_descr) $ \ fpath -> do-      files <- matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath-      for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)---- --------------------------------------------------------------------------------- Contributions to HaddockArgs (see also Doctest.hs for very similar code).--fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs-fromFlags env flags =-    mempty {-      argHideModules = (maybe mempty (All . not)-                        $ flagToMaybe (haddockInternal flags), mempty),-      argLinkSource = if fromFlag (haddockLinkedSource flags)-                               then Flag ("src/%{MODULE/./-}.html"-                                         ,"src/%{MODULE/./-}.html#%{NAME}"-                                         ,"src/%{MODULE/./-}.html#line-%{LINE}")-                               else NoFlag,-      argLinkedSource = haddockLinkedSource flags,-      argQuickJump = haddockQuickJump flags,-      argCssFile = haddockCss flags,-      argContents = fmap (fromPathTemplate . substPathTemplate env)-                    (haddockContents flags),-      argVerbose = maybe mempty (Any . (>= deafening))-                   . flagToMaybe $ haddockVerbosity flags,-      argOutput =-          Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++-                      [ Hoogle | Flag True <- [haddockHoogle flags] ]-                 of [] -> [ Html ]-                    os -> os,-      argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags,--      argGhcOptions = mempty { ghcOptExtra = ghcArgs }-    }-    where-      ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags--fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs-fromPackageDescription haddockTarget pkg_descr = mempty-    { argInterfaceFile = Flag $ haddockName pkg_descr-    , argPackageName = Flag $ packageId $ pkg_descr-    , argOutputDir = Dir $-        "doc" </> "html" </> haddockDirName haddockTarget pkg_descr-    , argPrologue = Flag $ ShortText.fromShortText $-        if ShortText.null desc-        then synopsis pkg_descr-        else desc-    , argTitle = Flag $ showPkg ++ subtitle-    }-  where-    desc = description pkg_descr-    showPkg = prettyShow (packageId pkg_descr)-    subtitle-        | ShortText.null (synopsis pkg_descr) = ""-        | otherwise                           = ": " ++ ShortText.fromShortText (synopsis pkg_descr)--componentGhcOptions :: Verbosity -> LocalBuildInfo-                 -> BuildInfo -> ComponentLocalBuildInfo -> FilePath-                 -> GhcOptions-componentGhcOptions verbosity lbi bi clbi odir =-  let f = case compilerFlavor (compiler lbi) of-            GHC   -> GHC.componentGhcOptions-            GHCJS -> GHCJS.componentGhcOptions-            _     -> error $-                       "Distribution.Simple.Haddock.componentGhcOptions:" ++-                       "haddock only supports GHC and GHCJS"-  in f verbosity lbi bi clbi odir--mkHaddockArgs :: Verbosity-              -> FilePath-              -> LocalBuildInfo-              -> ComponentLocalBuildInfo-              -> Maybe PathTemplate -- ^ template for HTML location-              -> Version-              -> [FilePath]-              -> BuildInfo-              -> IO HaddockArgs-mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles bi = do-    ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate-    let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {-                          -- Noooooooooo!!!!!111-                          -- haddock stomps on our precious .hi-                          -- and .o files. Workaround by telling-                          -- haddock to write them elsewhere.-                          ghcOptObjDir     = toFlag tmp,-                          ghcOptHiDir      = toFlag tmp,-                          ghcOptStubDir    = toFlag tmp-                      } `mappend` getGhcCppOpts haddockVersion bi-        sharedOpts = vanillaOpts {-                         ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                         ghcOptFPic        = toFlag True,-                         ghcOptHiSuffix    = toFlag "dyn_hi",-                         ghcOptObjSuffix   = toFlag "dyn_o",-                         ghcOptExtra       = hcSharedOptions GHC bi--                     }-    opts <- if withVanillaLib lbi-            then return vanillaOpts-            else if withSharedLib lbi-            then return sharedOpts-            else die' verbosity $ "Must have vanilla or shared libraries "-                       ++ "enabled in order to run haddock"--    return ifaceArgs-      { argGhcOptions  = opts-      , argTargets     = inFiles-      , argReexports   = getReexports clbi-      }--fromLibrary :: Verbosity-            -> FilePath-            -> LocalBuildInfo-            -> ComponentLocalBuildInfo-            -> Maybe PathTemplate -- ^ template for HTML location-            -> Version-            -> Library-            -> IO HaddockArgs-fromLibrary verbosity tmp lbi clbi htmlTemplate haddockVersion lib = do-    inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi-    args    <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion-                 inFiles (libBuildInfo lib)-    return args {-      argHideModules = (mempty, otherModules (libBuildInfo lib))-    }--fromExecutable :: Verbosity-               -> FilePath-               -> LocalBuildInfo-               -> ComponentLocalBuildInfo-               -> Maybe PathTemplate -- ^ template for HTML location-               -> Version-               -> Executable-               -> IO HaddockArgs-fromExecutable verbosity tmp lbi clbi htmlTemplate haddockVersion exe = do-    inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi-    args    <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate-                 haddockVersion inFiles (buildInfo exe)-    return args {-      argOutputDir  = Dir  $ unUnqualComponentName $ exeName exe,-      argTitle      = Flag $ unUnqualComponentName $ exeName exe-    }--fromForeignLib :: Verbosity-               -> FilePath-               -> LocalBuildInfo-               -> ComponentLocalBuildInfo-               -> Maybe PathTemplate -- ^ template for HTML location-               -> Version-               -> ForeignLib-               -> IO HaddockArgs-fromForeignLib verbosity tmp lbi clbi htmlTemplate haddockVersion flib = do-    inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi-    args    <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate-                 haddockVersion inFiles (foreignLibBuildInfo flib)-    return args {-      argOutputDir  = Dir  $ unUnqualComponentName $ foreignLibName flib,-      argTitle      = Flag $ unUnqualComponentName $ foreignLibName flib-    }--compToExe :: Component -> Maybe Executable-compToExe comp =-  case comp of-    CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } ->-      Just Executable {-        exeName    = testName test,-        modulePath = f,-        exeScope   = ExecutablePublic,-        buildInfo  = testBuildInfo test-      }-    CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } ->-      Just Executable {-        exeName    = benchmarkName bench,-        modulePath = f,-        exeScope   = ExecutablePublic,-        buildInfo  = benchmarkBuildInfo bench-      }-    CExe exe -> Just exe-    _ -> Nothing--getInterfaces :: Verbosity-              -> LocalBuildInfo-              -> ComponentLocalBuildInfo-              -> Maybe PathTemplate -- ^ template for HTML location-              -> IO HaddockArgs-getInterfaces verbosity lbi clbi htmlTemplate = do-    (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate-    traverse_ (warn (verboseUnmarkOutput verbosity)) warnings-    return $ mempty {-                 argInterfaces = packageFlags-               }--getReexports :: ComponentLocalBuildInfo -> [OpenModule]-getReexports LibComponentLocalBuildInfo {componentExposedModules = mods } =-    mapMaybe exposedReexport mods-getReexports _ = []--getGhcCppOpts :: Version-              -> BuildInfo-              -> GhcOptions-getGhcCppOpts haddockVersion bi =-    mempty {-        ghcOptExtensions   = toNubListR [EnableExtension CPP | needsCpp],-        ghcOptCppOptions   = defines-    }-  where-    needsCpp             = EnableExtension CPP `elem` usedExtensions bi-    defines              = [haddockVersionMacro]-    haddockVersionMacro  = "-D__HADDOCK_VERSION__="-                           ++ show (v1 * 1000 + v2 * 10 + v3)-      where-        (v1, v2, v3) = case versionNumbers haddockVersion of-            []        -> (0,0,0)-            [x]       -> (x,0,0)-            [x,y]     -> (x,y,0)-            (x:y:z:_) -> (x,y,z)--getGhcLibDir :: Verbosity -> LocalBuildInfo-             -> IO HaddockArgs-getGhcLibDir verbosity lbi = do-    l <- case compilerFlavor (compiler lbi) of-            GHC   -> GHC.getLibDir   verbosity lbi-            GHCJS -> GHCJS.getLibDir verbosity lbi-            _     -> error "haddock only supports GHC and GHCJS"-    return $ mempty { argGhcLibDir = Flag l }---- --------------------------------------------------------------------------------- | Call haddock with the specified arguments.-runHaddock :: Verbosity-              -> TempFileOptions-              -> Compiler-              -> Platform-              -> ConfiguredProgram-              -> HaddockArgs-              -> IO ()-runHaddock verbosity tmpFileOpts comp platform haddockProg args-  | null (argTargets args) = warn verbosity $-       "Haddocks are being requested, but there aren't any modules given "-    ++ "to create documentation for."-  | otherwise = do-    let haddockVersion = fromMaybe (error "unable to determine haddock version")-                        (programVersion haddockProg)-    renderArgs verbosity tmpFileOpts haddockVersion comp platform args $-      \(flags,result)-> do--        runProgram verbosity haddockProg flags--        notice verbosity $ "Documentation created: " ++ result---renderArgs :: Verbosity-              -> TempFileOptions-              -> Version-              -> Compiler-              -> Platform-              -> HaddockArgs-              -> (([String], FilePath) -> IO a)-              -> IO a-renderArgs verbosity tmpFileOpts version comp platform args k = do-  let haddockSupportsUTF8          = version >= mkVersion [2,14,4]-      haddockSupportsResponseFiles = version >  mkVersion [2,16,2]-  createDirectoryIfMissingVerbose verbosity True outputDir-  withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $-    \prologueFileName h -> do-          do-             when haddockSupportsUTF8 (hSetEncoding h utf8)-             hPutStrLn h $ fromFlag $ argPrologue args-             hClose h-             let pflag = "--prologue=" ++ prologueFileName-                 renderedArgs = pflag : renderPureArgs version comp platform args-             if haddockSupportsResponseFiles-               then-                 withResponseFile-                   verbosity-                   tmpFileOpts-                   outputDir-                   "haddock-response.txt"-                   (if haddockSupportsUTF8 then Just utf8 else Nothing)-                   renderedArgs-                   (\responseFileName -> k (["@" ++ responseFileName], result))-               else-                 k (renderedArgs, result)-    where-      outputDir = (unDir $ argOutputDir args)-      result = intercalate ", "-             . map (\o -> outputDir </>-                            case o of-                              Html -> "index.html"-                              Hoogle -> pkgstr <.> "txt")-             $ arg argOutput-            where-              pkgstr = prettyShow $ packageName pkgid-              pkgid = arg argPackageName-      arg f = fromFlag $ f args--renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String]-renderPureArgs version comp platform args = concat-    [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)-      . fromFlag . argInterfaceFile $ args--    , if isVersion 2 16-        then (\pkg -> [ "--package-name=" ++ prettyShow (pkgName pkg)-                      , "--package-version=" ++ prettyShow (pkgVersion pkg)-                      ])-             . fromFlag . argPackageName $ args-        else []--    , [ "--since-qual=external" | isVersion 2 20 ]--    , [ "--quickjump" | isVersion 2 19-                      , fromFlag . argQuickJump $ args ]--    , [ "--hyperlinked-source" | isVersion 2 17-                               , fromFlag . argLinkedSource $ args ]--    , (\(All b,xs) -> bool (map (("--hide=" ++) . prettyShow) xs) [] b)-                     . argHideModules $ args--    , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args--    , maybe [] (\(m,e,l) ->-                 ["--source-module=" ++ m-                 ,"--source-entity=" ++ e]-                 ++ if isVersion 2 14 then ["--source-entity-line=" ++ l]-                    else []-               ) . flagToMaybe . argLinkSource $ args--    , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args--    , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args--    , bool [] [verbosityFlag] . getAny . argVerbose $ args--    , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html")-      . fromFlag . argOutput $ args--    , renderInterfaces . argInterfaces $ args--    , (:[]) . ("--odir="++) . unDir . argOutputDir $ args--    , (:[]) . ("--title="++)-      . (bool (++" (internal documentation)")-         id (getAny $ argIgnoreExports args))-      . fromFlag . argTitle $ args--    , [ "--optghc=" ++ opt | let opts = argGhcOptions args-                           , opt <- renderGhcOptions comp platform opts ]--    , maybe [] (\l -> ["-B"++l]) $-      flagToMaybe (argGhcLibDir args) -- error if Nothing?--      -- https://github.com/haskell/haddock/pull/547-    , [ "--reexport=" ++ prettyShow r-      | r <- argReexports args-      , isVersion 2 19-      ]--    , argTargets $ args-    ]-    where-      renderInterfaces = map renderInterface--      renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath) -> String-      renderInterface (i, html, hypsrc) = "--read-interface=" ++-        (intercalate "," $ concat [ [ x | Just x <- [html] ]-                                  , [ x | Just _ <- [html]-                                        -- only render hypsrc path if html path-                                        -- is given and hyperlinked-source is-                                        -- enabled-                                        , Just x <- [hypsrc]-                                        , isVersion 2 17-                                        , fromFlag . argLinkedSource $ args-                                        ]-                                  , [ i ]-                                  ])--      bool a b c = if c then a else b-      isVersion major minor  = version >= mkVersion [major,minor]-      verbosityFlag-       | isVersion 2 5 = "--verbosity=1"-       | otherwise     = "--verbose"--------------------------------------------------------------------------------------- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and--- HTML paths, and an optional warning for packages with missing documentation.-haddockPackagePaths :: [InstalledPackageInfo]-                    -> Maybe (InstalledPackageInfo -> FilePath)-                    -> IO ([( FilePath        -- path to interface-                                                         -- file--                                       , Maybe FilePath  -- url to html-                                                         -- documentation--                                       , Maybe FilePath  -- url to hyperlinked-                                                         -- source-                                       )]-                                     , Maybe String      -- warning about-                                                         -- missing documentation-                                     )-haddockPackagePaths ipkgs mkHtmlPath = do-  interfaces <- sequenceA-    [ case interfaceAndHtmlPath ipkg of-        Nothing -> return (Left (packageId ipkg))-        Just (interface, html) -> do--          (html', hypsrc') <--            case html of-              Just htmlPath -> do-                let hypSrcPath = htmlPath </> defaultHyperlinkedSourceDirectory-                hypSrcExists <- doesDirectoryExist hypSrcPath-                return $ ( Just (fixFileUrl htmlPath)-                         , if hypSrcExists-                           then Just (fixFileUrl hypSrcPath)-                           else Nothing-                         )-              Nothing -> return (Nothing, Nothing)--          exists <- doesFileExist interface-          if exists-            then return (Right (interface, html', hypsrc'))-            else return (Left pkgid)-    | ipkg <- ipkgs, let pkgid = packageId ipkg-    , pkgName pkgid `notElem` noHaddockWhitelist-    ]--  let missing = [ pkgid | Left pkgid <- interfaces ]-      warning = "The documentation for the following packages are not "-             ++ "installed. No links will be generated to these packages: "-             ++ intercalate ", " (map prettyShow missing)-      flags = rights interfaces--  return (flags, if null missing then Nothing else Just warning)--  where-    -- Don't warn about missing documentation for these packages. See #1231.-    noHaddockWhitelist = map mkPackageName [ "rts" ]--    -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'.-    interfaceAndHtmlPath :: InstalledPackageInfo-                         -> Maybe (FilePath, Maybe FilePath)-    interfaceAndHtmlPath pkg = do-      interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)-      html <- case mkHtmlPath of-        Nothing     -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)-        Just mkPath -> Just (mkPath pkg)-      return (interface, if null html then Nothing else Just html)--    -- The 'haddock-html' field in the hc-pkg output is often set as a-    -- native path, but we need it as a URL. See #1064. Also don't "fix"-    -- the path if it is an interpolated one.-    fixFileUrl f | Nothing <- mkHtmlPath-                 , isAbsolute f = "file://" ++ f-                 | otherwise    = f--    -- 'src' is the default hyperlinked source directory ever since. It is-    -- not possible to configure that directory in any way in haddock.-    defaultHyperlinkedSourceDirectory = "src"---haddockPackageFlags :: Verbosity-                    -> LocalBuildInfo-                    -> ComponentLocalBuildInfo-                    -> Maybe PathTemplate-                    -> IO ([( FilePath        -- path to interface-                                              -- file--                            , Maybe FilePath  -- url to html-                                              -- documentation--                            , Maybe FilePath  -- url to hyperlinked-                                              -- source-                            )]-                          , Maybe String      -- warning about-                                              -- missing documentation-                          )-haddockPackageFlags verbosity lbi clbi htmlTemplate = do-  let allPkgs = installedPkgs lbi-      directDeps = map fst (componentPackageDeps clbi)-  transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of-    Left x    -> return x-    Right inf -> die' verbosity $ "internal error when calculating transitive "-                    ++ "package dependencies.\nDebug info: " ++ show inf-  haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath-    where-      mkHtmlPath                  = fmap expandTemplateVars htmlTemplate-      expandTemplateVars tmpl pkg =-        fromPathTemplate . substPathTemplate (env pkg) $ tmpl-      env pkg                     = haddockTemplateEnv lbi (packageId pkg)---haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv-haddockTemplateEnv lbi pkg_id =-  (PrefixVar, prefix (installDirTemplates lbi))-  -- We want the legacy unit ID here, because it gives us nice paths-  -- (Haddock people don't care about the dependencies)-  : initialPathTemplateEnv-      pkg_id-      (mkLegacyUnitId pkg_id)-      (compilerInfo (compiler lbi))-      (hostPlatform lbi)---- --------------------------------------------------------------------------------- hscolour support.--hscolour :: PackageDescription-         -> LocalBuildInfo-         -> [PPSuffixHandler]-         -> HscolourFlags-         -> IO ()-hscolour = hscolour' dieNoVerbosity ForDevelopment--hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found.-          -> HaddockTarget-          -> PackageDescription-          -> LocalBuildInfo-          -> [PPSuffixHandler]-          -> HscolourFlags-          -> IO ()-hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags =-    either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<<-      lookupProgramVersion verbosity hscolourProgram-      (orLaterVersion (mkVersion [1,8])) (withPrograms lbi)-  where-    go :: ConfiguredProgram -> IO ()-    go hscolourProg = do-      warn verbosity $-        "the 'cabal hscolour' command is deprecated in favour of 'cabal " ++-        "haddock --hyperlink-source' and will be removed in the next major " ++-        "release."--      setupMessage verbosity "Running hscolour for" (packageId pkg_descr)-      createDirectoryIfMissingVerbose verbosity True $-        hscolourPref haddockTarget distPref pkg_descr--      withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do-        componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity-        preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-        let-          doExe com = case (compToExe com) of-            Just exe -> do-              let outputDir = hscolourPref haddockTarget distPref pkg_descr-                              </> unUnqualComponentName (exeName exe) </> "src"-              runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi-            Nothing -> do-              warn (fromFlag $ hscolourVerbosity flags)-                "Unsupported component, skipping..."-              return ()-        case comp of-          CLib lib -> do-            let outputDir = hscolourPref haddockTarget distPref pkg_descr </> "src"-            runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi-          CFLib flib -> do-            let outputDir = hscolourPref haddockTarget distPref pkg_descr-                              </> unUnqualComponentName (foreignLibName flib) </> "src"-            runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi-          CExe   _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp-          CTest  _ -> when (fromFlag (hscolourTestSuites  flags)) $ doExe comp-          CBench _ -> when (fromFlag (hscolourBenchmarks  flags)) $ doExe comp--    stylesheet = flagToMaybe (hscolourCSS flags)--    verbosity  = fromFlag (hscolourVerbosity flags)-    distPref   = fromFlag (hscolourDistPref flags)--    runHsColour prog outputDir moduleFiles = do-         createDirectoryIfMissingVerbose verbosity True outputDir--         case stylesheet of -- copy the CSS file-           Nothing | programVersion prog >= Just (mkVersion [1,9]) ->-                       runProgram verbosity prog-                          ["-print-css", "-o" ++ outputDir </> "hscolour.css"]-                   | otherwise -> return ()-           Just s -> copyFileVerbose verbosity s (outputDir </> "hscolour.css")--         for_ moduleFiles $ \(m, inFile) ->-             runProgram verbosity prog-                    ["-css", "-anchor", "-o" ++ outFile m, inFile]-        where-          outFile m = outputDir </>-                      intercalate "-" (ModuleName.components m) <.> "html"--haddockToHscolour :: HaddockFlags -> HscolourFlags-haddockToHscolour flags =-    HscolourFlags {-      hscolourCSS         = haddockHscolourCss flags,-      hscolourExecutables = haddockExecutables flags,-      hscolourTestSuites  = haddockTestSuites  flags,-      hscolourBenchmarks  = haddockBenchmarks  flags,-      hscolourForeignLibs = haddockForeignLibs flags,-      hscolourVerbosity   = haddockVerbosity   flags,-      hscolourDistPref    = haddockDistPref    flags,-      hscolourCabalFilePath = haddockCabalFilePath flags-    }---- --------------------------------------------------------------------------------- Boilerplate Monoid instance.-instance Monoid HaddockArgs where-    mempty = gmempty-    mappend = (<>)--instance Semigroup HaddockArgs where-    (<>) = gmappend--instance Monoid Directory where-    mempty = Dir "."-    mappend = (<>)--instance Semigroup Directory where-    Dir m <> Dir n = Dir $ m </> n+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Haddock+-- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module deals with the @haddock@ and @hscolour@ commands.+-- It uses information about installed packages (from @ghc-pkg@) to find the+-- locations of documentation for dependent packages, so it can create links.+--+-- The @hscolour@ support allows generating HTML versions of the original+-- source, with coloured syntax highlighting.+module Distribution.Simple.Haddock+  ( haddock+  , haddock_setupHooks+  , createHaddockIndex+  , hscolour+  , hscolour_setupHooks+  , haddockPackagePaths+  , Visibility (..)+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import qualified Distribution.Simple.GHC as GHC+import qualified Distribution.Simple.GHCJS as GHCJS++-- local++import 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+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Parsec (simpleParsec)+import Distribution.Pretty+import Distribution.Simple.Build+import Distribution.Simple.BuildPaths+import Distribution.Simple.BuildTarget+import Distribution.Simple.Compiler+import Distribution.Simple.Errors+import Distribution.Simple.Flag+import Distribution.Simple.Glob (matchDirFileGlob)+import Distribution.Simple.InstallDirs+import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PreProcess+import Distribution.Simple.Program+import Distribution.Simple.Program.GHC+import qualified Distribution.Simple.Program.HcPkg as HcPkg+import Distribution.Simple.Program.ResponseFile+import Distribution.Simple.Register+import Distribution.Simple.Setup+import Distribution.Simple.SetupHooks.Internal+  ( BuildHooks (..)+  , noBuildHooks+  )+import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks+import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.ExposedModule+import Distribution.Types.LocalBuildInfo+import Distribution.Types.TargetInfo+import Distribution.Utils.Path hiding+  ( Dir+  )+import qualified Distribution.Utils.Path as Path+import qualified Distribution.Utils.ShortText as ShortText+import Distribution.Verbosity+import Distribution.Version++import Control.Monad+import Data.Bool (bool)+import Data.Either (rights)+import System.Directory (doesDirectoryExist, doesFileExist)+import System.FilePath (isAbsolute, normalise)+import System.IO (hClose, hPutStrLn, hSetEncoding, utf8)++-- ------------------------------------------------------------------------------+-- Types++-- | A record that represents the arguments to the haddock executable, a product+-- monoid.+data HaddockArgs = HaddockArgs+  { argInterfaceFile :: Flag FilePath+  -- ^ Path to the interface file, relative to argOutputDir, required.+  , argPackageName :: Flag PackageIdentifier+  -- ^ Package name, required.+  , argComponentName :: Flag String+  -- ^ Optional name used to construct haddock's `--package-name` option for+  -- various components (tests suites, sublibriaries, etc).+  , argHideModules :: (All, [ModuleName.ModuleName])+  -- ^ (Hide modules ?, modules to hide)+  , argIgnoreExports :: Any+  -- ^ Ignore export lists in modules?+  , argLinkSource :: Flag (Template, Template, Template)+  -- ^ (Template for modules, template for symbols, template for lines).+  , argLinkedSource :: Flag Bool+  -- ^ Generate hyperlinked sources+  , argQuickJump :: Flag Bool+  -- ^ Generate quickjump index+  , argCssFile :: Flag FilePath+  -- ^ Optional custom CSS file.+  , argContents :: Flag String+  -- ^ Optional URL to contents page.+  , argGenContents :: Flag Bool+  -- ^ Generate contents+  , argIndex :: Flag String+  -- ^ Optional URL to index page.+  , argGenIndex :: Flag Bool+  -- ^ Generate index+  , argBaseUrl :: Flag String+  -- ^ Optional base url from which static files will be loaded.+  , argVerbose :: Any+  , argOutput :: Flag [Output]+  -- ^ HTML or Hoogle doc or both? Required.+  , argInterfaces :: [(FilePath, Maybe String, Maybe String, Visibility)]+  -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)].+  , argOutputDir :: Directory+  -- ^ Where to generate the documentation.+  , argTitle :: Flag String+  -- ^ Page title, required.+  , argPrologue :: Flag String+  -- ^ Prologue text, required for 'haddock', ignored by 'haddocks'.+  , argPrologueFile :: Flag FilePath+  -- ^ Prologue file name, ignored by 'haddock', optional for 'haddocks'.+  , argGhcOptions :: GhcOptions+  -- ^ Additional flags to pass to GHC.+  , argGhcLibDir :: Flag FilePath+  -- ^ To find the correct GHC, required.+  , argReexports :: [OpenModule]+  -- ^ Re-exported modules+  , argTargets :: [FilePath]+  -- ^ Modules to process.+  , argResourcesDir :: Flag String+  -- ^ haddock's static \/ auxiliary files.+  , argUseUnicode :: Flag Bool+  -- ^ haddock's `--use-unicode` flag+  }+  deriving (Generic)++-- | The FilePath of a directory, it's a monoid under '(</>)'.+newtype Directory = Dir {unDir' :: FilePath} deriving (Read, Show, Eq, Ord)++-- NB: only correct at the top-level, after we have combined monoidally+-- the top-level output directory with the component subdir.+unDir :: Directory -> SymbolicPath Pkg (Path.Dir Artifacts)+unDir = makeSymbolicPath . normalise . unDir'++type Template = String++data Output = Html | Hoogle+  deriving (Eq)++-- ------------------------------------------------------------------------------+-- Haddock support++-- | Get Haddock program and check if it matches the request+getHaddockProg+  :: Verbosity+  -> ProgramDb+  -> Compiler+  -> HaddockArgs+  -> Flag Bool+  -- ^ quickjump feature+  -> IO (ConfiguredProgram, Version)+getHaddockProg verbosity programDb comp args quickJumpFlag = do+  let HaddockArgs+        { argQuickJump+        , argOutput+        } = args+      hoogle = Hoogle `elem` fromFlagOrDefault [] argOutput++  (haddockProg, version, _) <-+    requireProgramVersion+      verbosity+      haddockProgram+      (orLaterVersion (mkVersion [2, 0]))+      programDb++  -- various sanity checks+  when (hoogle && version < mkVersion [2, 2]) $+    dieWithException verbosity NoSupportForHoogle++  when (fromFlag argQuickJump && version < mkVersion [2, 19]) $ do+    let msg = "Haddock prior to 2.19 does not support the --quickjump flag."+        alt = "The generated documentation won't have the QuickJump feature."+    if Flag True == quickJumpFlag+      then dieWithException verbosity NoSupportForQuickJumpFlag+      else warn verbosity (msg ++ "\n" ++ alt)++  haddockGhcVersionStr <-+    getProgramOutput+      verbosity+      haddockProg+      ["--ghc-version"]+  case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of+    (Nothing, _) -> dieWithException verbosity NoGHCVersionFromHaddock+    (_, Nothing) -> dieWithException verbosity NoGHCVersionFromCompiler+    (Just haddockGhcVersion, Just ghcVersion)+      | haddockGhcVersion == ghcVersion -> return ()+      | otherwise -> dieWithException verbosity $ HaddockAndGHCVersionDoesntMatch ghcVersion haddockGhcVersion++  return (haddockProg, version)++haddock+  :: PackageDescription+  -> LocalBuildInfo+  -> [PPSuffixHandler]+  -> HaddockFlags+  -> IO ()+haddock = haddock_setupHooks noBuildHooks++haddock_setupHooks+  :: BuildHooks+  -> PackageDescription+  -> LocalBuildInfo+  -> [PPSuffixHandler]+  -> HaddockFlags+  -> IO ()+haddock_setupHooks+  _+  pkg_descr+  _+  _+  haddockFlags+    | not (hasLibs pkg_descr)+        && not (fromFlag $ haddockExecutables haddockFlags)+        && not (fromFlag $ haddockTestSuites haddockFlags)+        && not (fromFlag $ haddockBenchmarks haddockFlags)+        && not (fromFlag $ haddockForeignLibs haddockFlags) =+        warn (fromFlag $ setupVerbosity $ haddockCommonFlags haddockFlags) $+          "No documentation was generated as this package does not contain "+            ++ "a library. Perhaps you want to use the --executables, --tests,"+            ++ " --benchmarks or --foreign-libraries flags."+haddock_setupHooks+  (BuildHooks{preBuildComponentRules = mbPbcRules})+  pkg_descr+  lbi+  suffixes+  flags' = do+    let verbosity = fromFlag $ haddockVerbosity flags+        mbWorkDir = flagToMaybe $ haddockWorkingDir flags+        comp = compiler lbi+        platform = hostPlatform lbi+        config = configFlags lbi++        quickJmpFlag = haddockQuickJump flags'+        flags = case haddockTarget of+          ForDevelopment -> flags'+          ForHackage ->+            flags'+              { haddockHoogle = Flag True+              , haddockHtml = Flag True+              , haddockHtmlLocation = Flag (pkg_url ++ "/docs")+              , haddockContents = Flag (toPathTemplate pkg_url)+              , haddockLinkedSource = Flag True+              , haddockQuickJump = Flag True+              }+        pkg_url = "/package/$pkg-$version"+        flag f = fromFlag $ f flags++        tmpFileOpts =+          commonSetupTempFileOptions $ configCommonFlags config+        htmlTemplate =+          fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $+            flags+        haddockTarget =+          fromFlagOrDefault ForDevelopment (haddockForHackage flags')++    libdirArgs <- getGhcLibDir verbosity lbi+    -- The haddock-output-dir flag overrides any other documentation placement concerns.+    -- The point is to give the user full freedom over the location if they need it.+    let overrideWithOutputDir args = case haddockOutputDir flags of+          NoFlag -> args+          Flag dir -> args{argOutputDir = Dir dir}+    let commonArgs =+          overrideWithOutputDir $+            mconcat+              [ libdirArgs+              , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags+              , fromPackageDescription haddockTarget pkg_descr+              ]++    (haddockProg, version) <-+      getHaddockProg verbosity (withPrograms lbi) comp commonArgs quickJmpFlag++    -- We fall back to using HsColour only for versions of Haddock which don't+    -- support '--hyperlinked-sources'.+    let using_hscolour = flag haddockLinkedSource && version < mkVersion [2, 17]+    when using_hscolour $+      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)++    targets <- readTargetInfos verbosity pkg_descr lbi (haddockTargets flags)++    let+      targets' =+        case targets of+          [] -> allTargetsInBuildOrder' pkg_descr lbi+          _ -> targets++    internalPackageDB <-+      createInternalPackageDB verbosity lbi (flag $ setupDistPref . haddockCommonFlags)++    (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do+      curDir <- absoluteWorkingDirLBI lbi+      let+        component = targetComponent target+        clbi = targetCLBI target+        bi = componentBuildInfo component+        -- Include any build-tool-depends on build tools internal to the current package.+        progs' = addInternalBuildTools curDir pkg_descr lbi bi (withPrograms lbi)+        lbi' =+          lbi+            { withPrograms = progs'+            , withPackageDB = withPackageDB lbi ++ [internalPackageDB]+            , installedPkgs = index+            }++        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++      -- See Note [Hi Haddock Recompilation Avoidance]+      reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version $ \haddockArtifactsDirs -> do+        preBuildComponent runPreBuildHooks verbosity lbi' target+        preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes+        let+          doExe com = case (compToExe com) of+            Just exe -> do+              exeArgs <-+                fromExecutable+                  verbosity+                  haddockArtifactsDirs+                  lbi'+                  clbi+                  htmlTemplate+                  haddockTarget+                  pkg_descr+                  exe+                  commonArgs+              runHaddock+                verbosity+                mbWorkDir+                tmpFileOpts+                comp+                platform+                haddockProg+                True+                exeArgs+            Nothing -> do+              warn+                verbosity+                "Unsupported component, skipping..."+              return ()+          -- We define 'smsg' once and then reuse it inside the case, so that+          -- we don't say we are running Haddock when we actually aren't+          -- (e.g., Haddock is not run on non-libraries)+          smsg :: IO ()+          smsg =+            setupMessage'+              verbosity+              "Running Haddock on"+              (packageId pkg_descr)+              (componentLocalName clbi)+              (maybeComponentInstantiatedWith clbi)+        ipi <- case component of+          CLib lib -> do+            smsg+            libArgs <-+              fromLibrary+                verbosity+                haddockArtifactsDirs+                lbi'+                clbi+                htmlTemplate+                haddockTarget+                pkg_descr+                lib+                commonArgs+            runHaddock+              verbosity+              mbWorkDir+              tmpFileOpts+              comp+              platform+              haddockProg+              True+              libArgs+            inplaceDir <- absoluteWorkingDirLBI lbi++            let+              ipi =+                inplaceInstalledPackageInfo+                  inplaceDir+                  (flag $ setupDistPref . haddockCommonFlags)+                  pkg_descr+                  (mkAbiHash "inplace")+                  lib+                  lbi'+                  clbi++            debug verbosity $+              "Registering inplace:\n"+                ++ (InstalledPackageInfo.showInstalledPackageInfo ipi)++            registerPackage+              verbosity+              (compiler lbi')+              (withPrograms lbi')+              mbWorkDir+              (withPackageDB lbi')+              ipi+              HcPkg.defaultRegisterOptions+                { HcPkg.registerMultiInstance = True+                }++            return $ PackageIndex.insert ipi index+          CFLib flib ->+            when+              (flag haddockForeignLibs)+              ( do+                  smsg+                  flibArgs <-+                    fromForeignLib+                      verbosity+                      haddockArtifactsDirs+                      lbi'+                      clbi+                      htmlTemplate+                      haddockTarget+                      pkg_descr+                      flib+                      commonArgs+                  runHaddock+                    verbosity+                    mbWorkDir+                    tmpFileOpts+                    comp+                    platform+                    haddockProg+                    True+                    flibArgs+              )+              >> return index+          CExe _ -> when (flag haddockExecutables) (smsg >> doExe component) >> return index+          CTest test -> do+            when (flag haddockTestSuites) $ do+              smsg+              testArgs <-+                fromTest+                  verbosity+                  haddockArtifactsDirs+                  lbi'+                  clbi+                  htmlTemplate+                  haddockTarget+                  pkg_descr+                  test+                  commonArgs+              runHaddock+                verbosity+                mbWorkDir+                tmpFileOpts+                comp+                platform+                haddockProg+                True+                testArgs+            return index+          CBench bench -> do+            when (flag haddockBenchmarks) $ do+              smsg+              benchArgs <-+                fromBenchmark+                  verbosity+                  haddockArtifactsDirs+                  lbi'+                  clbi+                  htmlTemplate+                  haddockTarget+                  pkg_descr+                  bench+                  commonArgs+              runHaddock+                verbosity+                mbWorkDir+                tmpFileOpts+                comp+                platform+                haddockProg+                True+                benchArgs+            return index++        return ipi++    for_ (extraDocFiles pkg_descr) $ \fpath -> do+      files <- matchDirFileGlob verbosity (specVersion pkg_descr) mbWorkDir fpath+      let targetDir = Dir $ unDir' (argOutputDir commonArgs) </> haddockDirName haddockTarget pkg_descr+      for_ files $+        copyFileToCwd verbosity mbWorkDir (unDir targetDir)++-- | Execute 'Haddock' configured with 'HaddocksFlags'.  It is used to build+-- index and contents for documentation of multiple packages.+createHaddockIndex+  :: Verbosity+  -> ProgramDb+  -> Compiler+  -> Platform+  -> Maybe (SymbolicPath CWD (Path.Dir Pkg))+  -> HaddockProjectFlags+  -> IO ()+createHaddockIndex verbosity programDb comp platform mbWorkDir flags = do+  let args = fromHaddockProjectFlags flags+      tmpFileOpts =+        commonSetupTempFileOptions $ haddockProjectCommonFlags $ flags+  (haddockProg, _version) <-+    getHaddockProg verbosity programDb comp args (Flag True)+  runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg False args++-- ------------------------------------------------------------------------------+-- Contributions to HaddockArgs (see also Doctest.hs for very similar code).++fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs+fromFlags env flags =+  mempty+    { argHideModules =+        ( maybe mempty (All . not) $+            flagToMaybe (haddockInternal flags)+        , mempty+        )+    , argLinkSource =+        if fromFlag (haddockLinkedSource flags)+          then+            Flag+              ( "src/%{MODULE/./-}.html"+              , "src/%{MODULE/./-}.html#%{NAME}"+              , "src/%{MODULE/./-}.html#line-%{LINE}"+              )+          else NoFlag+    , argLinkedSource = haddockLinkedSource flags+    , argQuickJump = haddockQuickJump flags+    , argCssFile = haddockCss flags+    , argContents =+        fmap+          (fromPathTemplate . substPathTemplate env)+          (haddockContents flags)+    , argGenContents = Flag False+    , argIndex =+        fmap+          (fromPathTemplate . substPathTemplate env)+          (haddockIndex flags)+    , argGenIndex = Flag False+    , argBaseUrl = haddockBaseUrl flags+    , argResourcesDir = haddockResourcesDir flags+    , argVerbose =+        maybe mempty (Any . (>= deafening))+          . flagToMaybe+          $ setupVerbosity commonFlags+    , argOutput =+        Flag $ case [Html | Flag True <- [haddockHtml flags]]+          ++ [Hoogle | Flag True <- [haddockHoogle flags]] of+          [] -> [Html]+          os -> os+    , argOutputDir = maybe mempty (Dir . getSymbolicPath) . flagToMaybe $ setupDistPref commonFlags+    , argGhcOptions = mempty{ghcOptExtra = ghcArgs}+    , argUseUnicode = haddockUseUnicode flags+    }+  where+    ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags+    commonFlags = haddockCommonFlags flags++fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs+fromHaddockProjectFlags flags =+  mempty+    { argOutputDir = Dir (fromFlag $ haddockProjectDir flags)+    , argQuickJump = Flag True+    , argGenContents = Flag True+    , argGenIndex = Flag True+    , argPrologueFile = haddockProjectPrologue flags+    , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags)+    , argLinkedSource = Flag True+    , argResourcesDir = haddockProjectResourcesDir flags+    , argCssFile = haddockProjectCss flags+    }++fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs+fromPackageDescription _haddockTarget pkg_descr =+  mempty+    { argInterfaceFile = Flag $ haddockPath pkg_descr+    , argPackageName = Flag $ packageId $ pkg_descr+    , argOutputDir = Dir $ "doc" </> "html"+    , argPrologue =+        Flag $+          ShortText.fromShortText $+            if ShortText.null desc+              then synopsis pkg_descr+              else desc+    , argTitle = Flag $ showPkg ++ subtitle+    }+  where+    desc = description pkg_descr+    showPkg = prettyShow (packageId pkg_descr)+    subtitle+      | ShortText.null (synopsis pkg_descr) = ""+      | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr)++componentGhcOptions+  :: Verbosity+  -> LocalBuildInfo+  -> BuildInfo+  -> ComponentLocalBuildInfo+  -> SymbolicPath Pkg (Path.Dir build)+  -> GhcOptions+componentGhcOptions verbosity lbi bi clbi odir =+  let f = case compilerFlavor (compiler lbi) of+        GHC -> GHC.componentGhcOptions+        GHCJS -> GHCJS.componentGhcOptions+        _ ->+          error $+            "Distribution.Simple.Haddock.componentGhcOptions:"+              ++ "haddock only supports GHC and GHCJS"+   in f verbosity lbi bi clbi odir++{-+Note [Hi Haddock Recompilation Avoidance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Starting with Haddock 2.28, we no longer want to run Haddock's GHC session in+an arbitrary temporary directory. Doing so always causes recompilation during+documentation generation, which can now be avoided thanks to Hi Haddock.++Instead, we want to re-use the interface and object files produced by GHC.+We copy these intermediate files produced by GHC to temporary directories and+point haddock to them.++The reason why we can't use the GHC files /inplace/ is that haddock may have to+recompile (e.g. because of `haddock-options`). In that case, we want to be sure+the files produced by GHC do not get overwritten.++See https://github.com/haskell/cabal/pull/9177 for discussion.++(W.1) As it turns out, -stubdir is included in GHC's recompilation fingerprint.+This means that if we use a temporary directory for stubfiles produced by GHC+for the haddock invocation, haddock will trigger full recompilation since the+stubdir would be different.++So we don't use a temporary stubdir, despite the tmp o-dir and hi-dir:++We want to avoid at all costs haddock accidentally overwriting o-files and+hi-files (e.g. if a user specified haddock-option triggers recompilation), and+thus copy them to a temporary directory to pass them on to haddock. However,+stub files are much less problematic since ABI-incompatibility isn't at play+here, that is, there doesn't seem to be a GHC flag that could accidentally make+a stub file incompatible with the one produced by GHC from the same module.+-}++mkHaddockArgs+  :: Verbosity+  -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))+  -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.+  -- See Note [Hi Haddock Recompilation Avoidance]+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> Maybe PathTemplate+  -- ^ template for HTML location+  -> [SymbolicPath Pkg File]+  -> BuildInfo+  -> IO HaddockArgs+mkHaddockArgs verbosity (tmpObjDir, tmpHiDir, tmpStubDir) lbi clbi htmlTemplate inFiles bi = do+  let+    vanillaOpts' =+      componentGhcOptions normal lbi bi clbi (buildDir lbi)+    vanillaOpts =+      vanillaOpts'+        { -- See Note [Hi Haddock Recompilation Avoidance]+          ghcOptObjDir = toFlag tmpObjDir+        , ghcOptHiDir = toFlag tmpHiDir+        , ghcOptStubDir = toFlag tmpStubDir+        }+    sharedOpts =+      vanillaOpts+        { ghcOptDynLinkMode = toFlag GhcDynamicOnly+        , ghcOptFPic = toFlag True+        , ghcOptHiSuffix = toFlag "dyn_hi"+        , ghcOptObjSuffix = toFlag "dyn_o"+        , ghcOptExtra = hcSharedOptions GHC bi+        }+  ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate+  opts <-+    if withVanillaLib lbi+      then return vanillaOpts+      else+        if withSharedLib lbi+          then return sharedOpts+          else dieWithException verbosity MustHaveSharedLibraries++  return+    ifaceArgs+      { argGhcOptions = opts+      , argTargets = map getSymbolicPath inFiles+      , argReexports = getReexports clbi+      }++fromLibrary+  :: Verbosity+  -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))+  -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.+  -- See Note [Hi Haddock Recompilation Avoidance]+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> Maybe PathTemplate+  -- ^ template for HTML location+  -> HaddockTarget+  -> PackageDescription+  -> Library+  -> HaddockArgs+  -- ^ common args+  -> IO HaddockArgs+fromLibrary verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr lib commonArgs = do+  inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi+  args <-+    mkHaddockArgs+      verbosity+      haddockArtifactsDirs+      lbi+      clbi+      htmlTemplate+      inFiles+      (libBuildInfo lib)+  let args' =+        commonArgs+          <> args+            { argOutputDir =+                Dir $ haddockLibraryDirPath haddockTarget pkg_descr lib+            , argInterfaceFile = Flag $ haddockLibraryPath pkg_descr lib+            }+      args'' =+        args'+          { argHideModules = (mempty, otherModules (libBuildInfo lib))+          , argTitle = Flag $ haddockPackageLibraryName pkg_descr lib+          , argComponentName = toFlag (haddockPackageLibraryName' (pkgName (package pkg_descr)) (libName lib))+          , -- we need to accommodate for `argOutputDir`, see `haddockLibraryPath`+            argBaseUrl = case (libName lib, argBaseUrl args') of+              (LSubLibName _, Flag url) -> Flag $ ".." </> url+              (_, a) -> a+          , argContents = case (libName lib, argContents args') of+              (LSubLibName _, Flag url) -> Flag $ ".." </> url+              (_, a) -> a+          , argIndex = case (libName lib, argIndex args') of+              (LSubLibName _, Flag url) -> Flag $ ".." </> url+              (_, a) -> a+          }+  return args''++fromExecutable+  :: Verbosity+  -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))+  -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.+  -- See Note [Hi Haddock Recompilation Avoidance]+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> Maybe PathTemplate+  -- ^ template for HTML location+  -> HaddockTarget+  -> PackageDescription+  -> Executable+  -> HaddockArgs+  -- ^ common args+  -> IO HaddockArgs+fromExecutable verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr exe commonArgs = do+  inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi+  args <-+    mkHaddockArgs+      verbosity+      haddockArtifactsDirs+      lbi+      clbi+      htmlTemplate+      inFiles+      (buildInfo exe)+  let args' =+        commonArgs+          <> args+            { argOutputDir =+                Dir $+                  haddockDirName haddockTarget pkg_descr+                    </> unUnqualComponentName (exeName exe)+            }+  return+    args'+      { argTitle = Flag $ unUnqualComponentName $ exeName exe+      , -- we need to accommodate `argOutputDir`+        argBaseUrl = case argBaseUrl args' of+          Flag url -> Flag $ ".." </> url+          NoFlag -> NoFlag+      , argContents = case argContents args' of+          Flag url -> Flag $ ".." </> url+          NoFlag -> NoFlag+      , argIndex = case argIndex args' of+          Flag url -> Flag $ ".." </> url+          NoFlag -> NoFlag+      }++fromTest+  :: Verbosity+  -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))+  -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.+  -- See Note [Hi Haddock Recompilation Avoidance]+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> Maybe PathTemplate+  -- ^ template for HTML location+  -> HaddockTarget+  -> PackageDescription+  -> TestSuite+  -> HaddockArgs+  -- ^ common args+  -> IO HaddockArgs+fromTest verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr test commonArgs = do+  inFiles <- map snd `fmap` getTestSourceFiles verbosity lbi test clbi+  args <-+    mkHaddockArgs+      verbosity+      haddockArtifactsDirs+      lbi+      clbi+      htmlTemplate+      inFiles+      (testBuildInfo test)+  let args' =+        commonArgs+          <> args+            { argOutputDir =+                Dir $+                  haddockDirName haddockTarget pkg_descr+                    </> unUnqualComponentName (testName test)+            }+  return+    args'+      { argTitle = Flag $ prettyShow (packageName pkg_descr)+      , argComponentName = Flag $ prettyShow (packageName pkg_descr) ++ ":" ++ unUnqualComponentName (testName test)+      , -- we need to accommodate `argOutputDir`+        argBaseUrl = case argBaseUrl args' of+          Flag url -> Flag $ ".." </> url+          NoFlag -> NoFlag+      , argContents = case argContents args' of+          Flag url -> Flag $ ".." </> url+          NoFlag -> NoFlag+      , argIndex = case argIndex args' of+          Flag url -> Flag $ ".." </> url+          NoFlag -> NoFlag+      }++fromBenchmark+  :: Verbosity+  -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))+  -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.+  -- See Note [Hi Haddock Recompilation Avoidance]+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> Maybe PathTemplate+  -- ^ template for HTML location+  -> HaddockTarget+  -> PackageDescription+  -> Benchmark+  -> HaddockArgs+  -- ^ common args+  -> IO HaddockArgs+fromBenchmark verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr bench commonArgs = do+  inFiles <- map snd `fmap` getBenchmarkSourceFiles verbosity lbi bench clbi+  args <-+    mkHaddockArgs+      verbosity+      haddockArtifactsDirs+      lbi+      clbi+      htmlTemplate+      inFiles+      (benchmarkBuildInfo bench)+  let args' =+        commonArgs+          <> args+            { argOutputDir =+                Dir $+                  haddockDirName haddockTarget pkg_descr+                    </> unUnqualComponentName (benchmarkName bench)+            }+  return+    args'+      { argTitle = Flag $ prettyShow (packageName pkg_descr)+      , argComponentName = Flag $ prettyShow (packageName pkg_descr) ++ ":" ++ unUnqualComponentName (benchmarkName bench)+      , -- we need to accommodate `argOutputDir`+        argBaseUrl = case argBaseUrl args' of+          Flag url -> Flag $ ".." </> url+          NoFlag -> NoFlag+      , argContents = case argContents args' of+          Flag url -> Flag $ ".." </> url+          NoFlag -> NoFlag+      , argIndex = case argIndex args' of+          Flag url -> Flag $ ".." </> url+          NoFlag -> NoFlag+      }++fromForeignLib+  :: Verbosity+  -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))+  -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.+  -- See Note [Hi Haddock Recompilation Avoidance]+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> Maybe PathTemplate+  -- ^ template for HTML location+  -> HaddockTarget+  -> PackageDescription+  -> ForeignLib+  -> HaddockArgs+  -- ^ common args+  -> IO HaddockArgs+fromForeignLib verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr flib commonArgs = do+  inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi+  args <-+    mkHaddockArgs+      verbosity+      haddockArtifactsDirs+      lbi+      clbi+      htmlTemplate+      inFiles+      (foreignLibBuildInfo flib)+  let args' =+        commonArgs+          <> args+            { argOutputDir =+                Dir $+                  haddockDirName haddockTarget pkg_descr+                    </> unUnqualComponentName (foreignLibName flib)+            }+  return+    args'+      { argTitle = Flag $ unUnqualComponentName $ foreignLibName flib+      , -- we need to accommodate `argOutputDir`+        argBaseUrl = case argBaseUrl args' of+          Flag url -> Flag $ ".." </> url+          NoFlag -> NoFlag+      , argContents = case argContents args' of+          Flag url -> Flag $ ".." </> url+          NoFlag -> NoFlag+      , argIndex = case argIndex args' of+          Flag url -> Flag $ ".." </> url+          NoFlag -> NoFlag+      }++compToExe :: Component -> Maybe Executable+compToExe comp =+  case comp of+    CTest test@TestSuite{testInterface = TestSuiteExeV10 _ f} ->+      Just+        Executable+          { exeName = testName test+          , modulePath = f+          , exeScope = ExecutablePublic+          , buildInfo = testBuildInfo test+          }+    CBench bench@Benchmark{benchmarkInterface = BenchmarkExeV10 _ f} ->+      Just+        Executable+          { exeName = benchmarkName bench+          , modulePath = f+          , exeScope = ExecutablePublic+          , buildInfo = benchmarkBuildInfo bench+          }+    CExe exe -> Just exe+    _ -> Nothing++getInterfaces+  :: Verbosity+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> Maybe PathTemplate+  -- ^ template for HTML location+  -> IO HaddockArgs+getInterfaces verbosity lbi clbi htmlTemplate = do+  (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate+  traverse_ (warn (verboseUnmarkOutput verbosity)) warnings+  return $+    mempty+      { argInterfaces = packageFlags+      }++getReexports :: ComponentLocalBuildInfo -> [OpenModule]+getReexports LibComponentLocalBuildInfo{componentExposedModules = mods} =+  mapMaybe exposedReexport mods+getReexports _ = []++getGhcLibDir+  :: Verbosity+  -> LocalBuildInfo+  -> IO HaddockArgs+getGhcLibDir verbosity lbi = do+  l <- case compilerFlavor (compiler lbi) of+    GHC -> GHC.getLibDir verbosity lbi+    GHCJS -> GHCJS.getLibDir verbosity lbi+    _ -> error "haddock only supports GHC and GHCJS"+  return $ mempty{argGhcLibDir = Flag l}++-- | If Hi Haddock is supported, this function creates temporary directories+-- and copies existing interface and object files produced by GHC into them,+-- then passes them off to the given continuation.+--+-- If Hi Haddock is _not_ supported, we can't re-use GHC's compilation files.+-- Instead, we use a clean temporary directory to the continuation,+-- with no hope for recompilation avoidance.+--+-- See Note [Hi Haddock Recompilation Avoidance]+reusingGHCCompilationArtifacts+  :: Verbosity+  -> TempFileOptions+  -> Maybe (SymbolicPath CWD (Path.Dir Pkg))+  -- ^ Working directory+  -> LocalBuildInfo+  -> BuildInfo+  -> ComponentLocalBuildInfo+  -> Version+  -- ^ Haddock's version+  -> ((SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) -> IO r)+  -- ^ Continuation+  -> IO r+reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version act+  | version >= mkVersion [2, 28, 0] = do+      withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-objs" $ \tmpObjDir ->+        withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-his" $ \tmpHiDir -> do+          -- Re-use ghc's interface and obj files, but first copy them to+          -- somewhere where it is safe if haddock overwrites them+          let+            vanillaOpts = componentGhcOptions normal lbi bi clbi (buildDir lbi)+            i = interpretSymbolicPath mbWorkDir+            copyDir getGhcDir tmpDir = do+              let ghcDir = i $ fromFlag $ getGhcDir vanillaOpts+              ghcDirExists <- doesDirectoryExist ghcDir+              -- Don't try to copy artifacts if they don't exist, e.g. if+              -- we have not yet run the 'build' command.+              when ghcDirExists $+                copyDirectoryRecursive verbosity ghcDir (i tmpDir)+          copyDir ghcOptObjDir tmpObjDir+          copyDir ghcOptHiDir tmpHiDir+          -- copyDir ghcOptStubDir tmpStubDir -- (see W.1 in Note [Hi Haddock Recompilation Avoidance])++          act (tmpObjDir, tmpHiDir, fromFlag $ ghcOptHiDir vanillaOpts)+  | otherwise = do+      withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "tmp" $+        \tmpFallback -> act (tmpFallback, tmpFallback, tmpFallback)++-- ------------------------------------------------------------------------------++-- | Call haddock with the specified arguments.+runHaddock+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Path.Dir Pkg))+  -> TempFileOptions+  -> Compiler+  -> Platform+  -> ConfiguredProgram+  -> Bool+  -- ^ require targets+  -> HaddockArgs+  -> IO ()+runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg requireTargets args+  | requireTargets && null (argTargets args) =+      warn verbosity $+        "Haddocks are being requested, but there aren't any modules given "+          ++ "to create documentation for."+  | otherwise = do+      let haddockVersion =+            fromMaybe+              (error "unable to determine haddock version")+              (programVersion haddockProg)+      renderArgs verbosity mbWorkDir tmpFileOpts haddockVersion comp platform args $+        \flags result -> do+          runProgramCwd verbosity mbWorkDir haddockProg flags+          notice verbosity $ "Documentation created: " ++ result++renderArgs+  :: forall a+   . Verbosity+  -> Maybe (SymbolicPath CWD (Path.Dir Pkg))+  -> TempFileOptions+  -> Version+  -> Compiler+  -> Platform+  -> HaddockArgs+  -> ([String] -> FilePath -> IO a)+  -> IO a+renderArgs verbosity mbWorkDir tmpFileOpts version comp platform args k = do+  let haddockSupportsUTF8 = version >= mkVersion [2, 14, 4]+      haddockSupportsResponseFiles = version > mkVersion [2, 16, 2]+  createDirectoryIfMissingVerbose verbosity True (i outputDir)+  let withPrologueArgs prologueArgs =+        let renderedArgs = prologueArgs <> renderPureArgs version comp platform args+         in if haddockSupportsResponseFiles+              then+                withResponseFile+                  verbosity+                  tmpFileOpts+                  "haddock-response.txt"+                  (if haddockSupportsUTF8 then Just utf8 else Nothing)+                  renderedArgs+                  (\responseFileName -> k ["@" ++ responseFileName] result)+              else k renderedArgs result+  case (argPrologueFile args, argPrologue args) of+    (Flag pfile, _) ->+      withPrologueArgs ["--prologue=" ++ pfile]+    (_, Flag prologueText) ->+      withTempFileEx tmpFileOpts "haddock-prologue.txt" $+        \prologueFileName h -> do+          when haddockSupportsUTF8 (hSetEncoding h utf8)+          hPutStrLn h prologueText+          hClose h+          withPrologueArgs ["--prologue=" ++ u prologueFileName]+    (NoFlag, NoFlag) ->+      withPrologueArgs []+  where+    -- See Note [Symbolic paths] in Distribution.Utils.Path+    i = interpretSymbolicPath mbWorkDir+    u :: SymbolicPath Pkg to -> FilePath+    u = interpretSymbolicPathCWD++    outputDir = coerceSymbolicPath $ unDir $ argOutputDir args+    isNotArgContents = isNothing (flagToMaybe $ argContents args)+    isNotArgIndex = isNothing (flagToMaybe $ argIndex args)+    isArgGenIndex = fromFlagOrDefault False (argGenIndex args)+    -- Haddock, when generating HTML, does not generate an index if the options+    -- --use-contents or --use-index are passed to it. See+    -- https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-use-contents+    isIndexGenerated = isArgGenIndex && isNotArgContents && isNotArgIndex+    result =+      intercalate ", "+        . map+          ( \o ->+              i outputDir+                </> case o of+                  Html+                    | isIndexGenerated ->+                        "index.html"+                  Html+                    | otherwise ->+                        mempty+                  Hoogle -> pkgstr <.> "txt"+          )+        . fromFlagOrDefault [Html]+        . argOutput+        $ args+      where+        pkgstr = prettyShow $ packageName pkgid+        pkgid = arg argPackageName+    arg f = fromFlag $ f args++renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String]+renderPureArgs version comp platform args =+  concat+    [ map (\f -> "--dump-interface=" ++ u (unDir (argOutputDir args)) </> f)+        . flagToList+        . argInterfaceFile+        $ args+    , if haddockSupportsPackageName+        then+          maybe+            []+            ( \pkg ->+                [ "--package-name="+                    ++ case argComponentName args of+                      Flag name -> name+                      _ -> prettyShow (pkgName pkg)+                , "--package-version=" ++ prettyShow (pkgVersion pkg)+                ]+            )+            . flagToMaybe+            . argPackageName+            $ args+        else []+    , ["--since-qual=external" | isVersion 2 20]+    , [ "--quickjump" | isVersion 2 19, True <- flagToList . argQuickJump $ args+      ]+    , ["--hyperlinked-source" | isHyperlinkedSource]+    , (\(All b, xs) -> bool [] (map (("--hide=" ++) . prettyShow) xs) b)+        . argHideModules+        $ args+    , bool [] ["--ignore-all-exports"] . getAny . argIgnoreExports $ args+    , -- Haddock's --source-* options are ignored once --hyperlinked-source is+      -- set.+      -- See https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-hyperlinked-source+      -- To avoid Haddock's warning, we only set --source-* options if+      -- --hyperlinked-source is not set.+      if isHyperlinkedSource+        then []+        else+          maybe+            []+            ( \(m, e, l) ->+                [ "--source-module=" ++ m+                , "--source-entity=" ++ e+                ]+                  ++ if isVersion 2 14+                    then ["--source-entity-line=" ++ l]+                    else []+            )+            . flagToMaybe+            . argLinkSource+            $ args+    , maybe [] ((: []) . ("--css=" ++)) . flagToMaybe . argCssFile $ args+    , maybe [] ((: []) . ("--use-contents=" ++)) . flagToMaybe . argContents $ args+    , bool [] ["--gen-contents"] . fromFlagOrDefault False . argGenContents $ args+    , maybe [] ((: []) . ("--use-index=" ++)) . flagToMaybe . argIndex $ args+    , bool [] ["--gen-index"] . fromFlagOrDefault False . argGenIndex $ args+    , maybe [] ((: []) . ("--base-url=" ++)) . flagToMaybe . argBaseUrl $ args+    , bool [verbosityFlag] [] . getAny . argVerbose $ args+    , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html")+        . fromFlagOrDefault []+        . argOutput+        $ args+    , renderInterfaces . argInterfaces $ args+    , (: []) . ("--odir=" ++) . u . unDir . argOutputDir $ args+    , maybe+        []+        ( (: [])+            . ("--title=" ++)+            . ( bool+                  id+                  (++ " (internal documentation)")+                  (getAny $ argIgnoreExports args)+              )+        )+        . flagToMaybe+        . argTitle+        $ args+    , [ "--optghc=" ++ opt | let opts = argGhcOptions args, opt <- renderGhcOptions comp platform opts+      ]+    , maybe [] (\l -> ["-B" ++ l]) $+        flagToMaybe (argGhcLibDir args) -- error if Nothing?+    , -- https://github.com/haskell/haddock/pull/547+      [ "--reexport=" ++ prettyShow r+      | r <- argReexports args+      , isVersion 2 19+      ]+    , argTargets $ args+    , maybe [] ((: []) . (resourcesDirFlag ++)) . flagToMaybe . argResourcesDir $ args+    , -- Do not re-direct compilation output to a temporary directory (--no-tmp-comp-dir)+      -- We pass this option by default to haddock to avoid recompilation+      -- See Note [Hi Haddock Recompilation Avoidance]+      ["--no-tmp-comp-dir" | version >= mkVersion [2, 28, 0]]+    , bool [] ["--use-unicode"] . fromFlagOrDefault False . argUseUnicode $ args+    ]+  where+    -- See Note [Symbolic paths] in Distribution.Utils.Path+    u = interpretSymbolicPathCWD+    renderInterfaces = map renderInterface++    renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath, Visibility) -> String+    renderInterface (i, html, hypsrc, visibility) =+      "--read-interface="+        ++ intercalate+          ","+          ( concat+              [ [fromMaybe "" html]+              , -- only render hypsrc path if html path+                -- is given and hyperlinked-source is+                -- enabled++                [ case (html, hypsrc) of+                    (Nothing, _) -> ""+                    (_, Nothing) -> ""+                    (_, Just x)+                      | isVersion 2 17+                      , fromFlagOrDefault False . argLinkedSource $ args ->+                          x+                      | otherwise ->+                          ""+                ]+              , if haddockSupportsVisibility+                  then+                    [ case visibility of+                        Visible -> "visible"+                        Hidden -> "hidden"+                    ]+                  else []+              , [i]+              ]+          )++    isVersion major minor = version >= mkVersion [major, minor]+    verbosityFlag+      | isVersion 2 5 = "--verbosity=1"+      | otherwise = "--verbose"+    resourcesDirFlag+      | isVersion 2 29 = "--resources-dir="+      | otherwise = "--lib="+    haddockSupportsVisibility = version >= mkVersion [2, 26, 1]+    haddockSupportsPackageName = version > mkVersion [2, 16]+    haddockSupportsHyperlinkedSource = isVersion 2 17+    isHyperlinkedSource =+      haddockSupportsHyperlinkedSource+        && fromFlagOrDefault False (argLinkedSource args)++---------------------------------------------------------------------------------++-- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and+-- HTML paths, and an optional warning for packages with missing documentation.+haddockPackagePaths+  :: [InstalledPackageInfo]+  -> Maybe (InstalledPackageInfo -> FilePath)+  -> IO+      ( [ ( FilePath -- path to interface+      -- file+          , Maybe FilePath -- url to html+          -- documentation+          , Maybe FilePath -- url to hyperlinked+          -- source+          , Visibility+          )+        ]+      , Maybe String -- warning about+      -- missing documentation+      )+haddockPackagePaths ipkgs mkHtmlPath = do+  interfaces <-+    sequenceA+      [ case interfaceAndHtmlPath ipkg of+        Nothing -> do+          return (Left (packageId ipkg))+        Just (interface, html) -> do+          (html', hypsrc') <-+            case html of+              Just htmlPath -> do+                let hypSrcPath = htmlPath </> defaultHyperlinkedSourceDirectory+                hypSrcExists <- doesDirectoryExist hypSrcPath+                return $+                  ( Just (fixFileUrl htmlPath)+                  , if hypSrcExists+                      then Just (fixFileUrl hypSrcPath)+                      else Nothing+                  )+              Nothing -> return (Nothing, Nothing)++          exists <- doesFileExist interface+          if exists+            then return (Right (interface, html', hypsrc', Visible))+            else return (Left pkgid)+      | ipkg <- ipkgs+      , let pkgid = packageId ipkg+      , pkgName pkgid `notElem` noHaddockWhitelist+      ]++  let missing = [pkgid | Left pkgid <- interfaces]+      warning =+        "The following packages have no Haddock documentation "+          ++ "installed. No links will be generated to these packages: "+          ++ intercalate ", " (map prettyShow missing)+      flags = rights interfaces++  return (flags, if null missing then Nothing else Just warning)+  where+    -- Don't warn about missing documentation for these packages. See #1231.+    noHaddockWhitelist = map mkPackageName ["rts"]++    -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'.+    interfaceAndHtmlPath+      :: InstalledPackageInfo+      -> Maybe (FilePath, Maybe FilePath)+    interfaceAndHtmlPath pkg = do+      interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)+      html <- case mkHtmlPath of+        Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)+        Just mkPath -> Just (mkPath pkg)+      return (interface, if null html then Nothing else Just html)++    -- The 'haddock-html' field in the hc-pkg output is often set as a+    -- native path, but we need it as a URL. See #1064. Also don't "fix"+    -- the path if it is an interpolated one.+    fixFileUrl f+      | Nothing <- mkHtmlPath+      , isAbsolute f =+          "file://" ++ f+      | otherwise = f++    -- 'src' is the default hyperlinked source directory ever since. It is+    -- not possible to configure that directory in any way in haddock.+    defaultHyperlinkedSourceDirectory = "src"++haddockPackageFlags+  :: Verbosity+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> Maybe PathTemplate+  -> IO+      ( [ ( FilePath -- path to interface+      -- file+          , Maybe FilePath -- url to html+          -- documentation+          , Maybe FilePath -- url to hyperlinked+          -- source+          , Visibility+          )+        ]+      , Maybe String -- warning about+      -- missing documentation+      )+haddockPackageFlags verbosity lbi clbi htmlTemplate = do+  let allPkgs = installedPkgs lbi+      directDeps = map fst (componentPackageDeps clbi)+  transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of+    Left x -> return x+    Right inf ->+      dieWithException verbosity $ HaddockPackageFlags inf++  haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath+  where+    mkHtmlPath = fmap expandTemplateVars htmlTemplate+    expandTemplateVars tmpl pkg =+      fromPathTemplate . substPathTemplate (env pkg) $ tmpl+    env pkg = haddockTemplateEnv lbi (packageId pkg)++haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv+haddockTemplateEnv lbi pkg_id =+  (PrefixVar, prefix (installDirTemplates lbi))+    -- We want the legacy unit ID here, because it gives us nice paths+    -- (Haddock people don't care about the dependencies)+    : initialPathTemplateEnv+      pkg_id+      (mkLegacyUnitId pkg_id)+      (compilerInfo (compiler lbi))+      (hostPlatform lbi)++-- ------------------------------------------------------------------------------+-- hscolour support.++hscolour+  :: PackageDescription+  -> LocalBuildInfo+  -> [PPSuffixHandler]+  -> HscolourFlags+  -> IO ()+hscolour = hscolour_setupHooks noBuildHooks++hscolour_setupHooks+  :: BuildHooks+  -> PackageDescription+  -> LocalBuildInfo+  -> [PPSuffixHandler]+  -> HscolourFlags+  -> IO ()+hscolour_setupHooks setupHooks =+  hscolour' setupHooks dieNoVerbosity ForDevelopment++hscolour'+  :: BuildHooks+  -> (String -> IO ())+  -- ^ Called when the 'hscolour' exe is not found.+  -> HaddockTarget+  -> PackageDescription+  -> LocalBuildInfo+  -> [PPSuffixHandler]+  -> HscolourFlags+  -> IO ()+hscolour'+  (BuildHooks{preBuildComponentRules = mbPbcRules})+  onNoHsColour+  haddockTarget+  pkg_descr+  lbi+  suffixes+  flags =+    either (\excep -> onNoHsColour $ exceptionMessage excep) (\(hscolourProg, _, _) -> go hscolourProg)+      =<< lookupProgramVersion+        verbosity+        hscolourProgram+        (orLaterVersion (mkVersion [1, 8]))+        (withPrograms lbi)+    where+      common = hscolourCommonFlags flags+      verbosity = 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 hscolourProg = do+        warn verbosity $+          "the 'cabal hscolour' command is deprecated in favour of 'cabal "+            ++ "haddock --hyperlink-source' and will be removed in the next major "+            ++ "release."++        setupMessage verbosity "Running hscolour for" (packageId pkg_descr)+        createDirectoryIfMissingVerbose verbosity True $+          i $+            hscolourPref haddockTarget distPref pkg_descr++        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+          preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes+          let+            doExe com = case (compToExe com) of+              Just exe -> do+                let outputDir =+                      hscolourPref haddockTarget distPref pkg_descr+                        </> makeRelativePathEx (unUnqualComponentName (exeName exe) </> "src")+                runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi+              Nothing -> do+                warn verbosity "Unsupported component, skipping..."+                return ()+          case comp of+            CLib lib -> do+              let outputDir = hscolourPref haddockTarget distPref pkg_descr </> makeRelativePathEx "src"+              runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi+            CFLib flib -> do+              let outputDir =+                    hscolourPref haddockTarget distPref pkg_descr+                      </> makeRelativePathEx+                        ( unUnqualComponentName (foreignLibName flib)+                            </> "src"+                        )+              runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi+            CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp+            CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp+            CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp++      stylesheet = flagToMaybe (hscolourCSS flags)++      runHsColour+        :: ConfiguredProgram+        -> SymbolicPath Pkg to+        -> [(ModuleName.ModuleName, SymbolicPath Pkg to1)]+        -> IO ()+      runHsColour prog outputDir moduleFiles = do+        createDirectoryIfMissingVerbose verbosity True (i outputDir)++        case stylesheet of -- copy the CSS file+          Nothing+            | programVersion prog >= Just (mkVersion [1, 9]) ->+                runProgramCwd+                  verbosity+                  mbWorkDir+                  prog+                  ["-print-css", "-o" ++ u outputDir </> "hscolour.css"]+            | otherwise -> return ()+          Just s -> copyFileVerbose verbosity s (i outputDir </> "hscolour.css")++        for_ moduleFiles $ \(m, inFile) ->+          runProgramCwd+            verbosity+            mbWorkDir+            prog+            ["-css", "-anchor", "-o" ++ outFile m, u inFile]+        where+          outFile m =+            i outputDir+              </> intercalate "-" (ModuleName.components m)+                <.> "html"++haddockToHscolour :: HaddockFlags -> HscolourFlags+haddockToHscolour flags =+  HscolourFlags+    { hscolourCommonFlags = haddockCommonFlags flags+    , hscolourCSS = haddockHscolourCss flags+    , hscolourExecutables = haddockExecutables flags+    , hscolourTestSuites = haddockTestSuites flags+    , hscolourBenchmarks = haddockBenchmarks flags+    , hscolourForeignLibs = haddockForeignLibs flags+    }++-- ------------------------------------------------------------------------------+-- Boilerplate Monoid instance.+instance Monoid HaddockArgs where+  mempty = gmempty+  mappend = (<>)++instance Semigroup HaddockArgs where+  (<>) = gmappend++instance Monoid Directory where+  mempty = Dir "."+  mappend = (<>)++instance Semigroup Directory where+  Dir m <> Dir n = Dir $ m </> n
− src/Distribution/Simple/HaskellSuite.hs 
@@ -1,228 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}--module Distribution.Simple.HaskellSuite where--import Prelude ()-import Distribution.Compat.Prelude--import qualified Data.List.NonEmpty as NE--import Distribution.Simple.Program-import Distribution.Simple.Compiler-import Distribution.Simple.Utils-import Distribution.Simple.BuildPaths-import Distribution.Verbosity-import Distribution.Version-import Distribution.Pretty-import Distribution.Parsec (simpleParsec)-import Distribution.Package-import Distribution.InstalledPackageInfo hiding (includeDirs)-import Distribution.Simple.PackageIndex as PackageIndex-import Distribution.PackageDescription-import Distribution.Simple.LocalBuildInfo-import Distribution.System (Platform)-import Distribution.Utils.Path-import Language.Haskell.Extension-import Distribution.Simple.Program.Builtin--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 (die' verbosity 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 (die' verbosity "haskell-suite: couldn't determine compiler version") return $-      simpleParsec versionStr-  return (name, version)--getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe CompilerFlag)]-getExtensions verbosity prog = do-  extStrs <--    lines `fmap`-    rawSystemStdout verbosity (programPath prog) ["--supported-extensions"]-  return-    [ (ext, Just $ "-X" ++ prettyShow ext) | Just ext <- map simpleParsec extStrs ]--getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, CompilerFlag)]-getLanguages verbosity prog = do-  langStrs <--    lines `fmap`-    rawSystemStdout verbosity (programPath prog) ["--supported-languages"]-  return-    [ (ext, "-G" ++ prettyShow ext) | Just ext <- map simpleParsec langStrs ]---- Other compilers do some kind of a packagedb stack check here. Not sure--- if we need something like that as well.-getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb-                     -> IO InstalledPackageIndex-getInstalledPackages verbosity packagedbs progdb =-  liftM (PackageIndex.fromList . concat) $ for packagedbs $ \packagedb ->-    do str <--        getDbProgramOutput verbosity haskellSuitePkgProgram progdb-                ["dump", packageDbOpt packagedb]-         `catchExit` \_ -> die' verbosity $ "pkg dump failed"-       case parsePackages str of-         Right ok -> return ok-         _       -> die' verbosity "failed to parse output of 'pkg dump'"--  where-    parsePackages str =-        case partitionEithers $ map (parseInstalledPackageInfo . toUTF8BS) (splitPkgs str) of-            ([], ok)   -> Right [ pkg | (_, pkg) <- ok ]-            (msgss, _) -> Left (foldMap NE.toList msgss)--    splitPkgs :: String -> [String]-    splitPkgs = map unlines . splitWith ("---" ==) . lines-      where-        splitWith :: (a -> Bool) -> [a] -> [[a]]-        splitWith p xs = ys : case zs of-                           []   -> []-                           _:ws -> splitWith p ws-          where (ys,zs) = break p xs--buildLib-  :: Verbosity -> PackageDescription -> LocalBuildInfo-  -> Library -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity pkg_descr lbi lib clbi = do-  -- In future, there should be a mechanism for the compiler to request any-  -- number of the above parameters (or their parts) — in particular,-  -- pieces of PackageDescription.-  ---  -- For now, we only pass those that we know are used.--  let odir = buildDir lbi-      bi = libBuildInfo lib-      srcDirs = map getSymbolicPath (hsSourceDirs bi) ++ [odir]-      dbStack = withPackageDB lbi-      language = fromMaybe Haskell98 (defaultLanguage bi)-      progdb = withPrograms lbi-      pkgid = packageId pkg_descr--  runDbProgram verbosity haskellSuiteProgram progdb $-    [ "compile", "--build-dir", odir ] ++-    concat [ ["-i", d] | d <- srcDirs ] ++-    concat [ ["-I", d] | d <- [autogenComponentModulesDir lbi clbi-                              ,autogenPackageModulesDir lbi-                              ,odir] ++ includeDirs bi ] ++-    [ packageDbOpt pkgDb | pkgDb <- dbStack ] ++-    [ "--package-name", prettyShow pkgid ] ++-    concat [ ["--package-id", prettyShow ipkgid ]-           | (ipkgid, _) <- componentPackageDeps clbi ] ++-    ["-G", prettyShow language] ++-    concat [ ["-X", prettyShow ex] | ex <- usedExtensions bi ] ++-    cppOptions (libBuildInfo lib) ++-    [ prettyShow modu | modu <- allLibModules lib clbi ]----installLib-  :: Verbosity-  -> LocalBuildInfo-  -> FilePath  -- ^install location-  -> FilePath  -- ^install location for dynamic libraries-  -> FilePath  -- ^Build location-  -> PackageDescription-  -> Library-  -> ComponentLocalBuildInfo-  -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib clbi = do-  let progdb = withPrograms lbi-  runDbProgram verbosity haskellSuitePkgProgram progdb $-    [ "install-library"-    , "--build-dir", builtDir-    , "--target-dir", targetDir-    , "--dynlib-target-dir", dynlibTargetDir-    , "--package-id", prettyShow $ packageId pkg-    ] ++ map prettyShow (allLibModules lib clbi)--registerPackage-  :: Verbosity-  -> ProgramDb-  -> PackageDBStack-  -> InstalledPackageInfo-  -> IO ()-registerPackage verbosity progdb packageDbs installedPkgInfo = do-  (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb--  runProgramInvocation verbosity $-    (programInvocation hspkg-      ["update", packageDbOpt $ registrationPackageDB packageDbs])-      { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo }--initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO ()-initPackageDB verbosity progdb dbPath =-  runDbProgram verbosity haskellSuitePkgProgram progdb-    ["init", dbPath]--packageDbOpt :: PackageDB -> String-packageDbOpt GlobalPackageDB        = "--global"-packageDbOpt UserPackageDB          = "--user"-packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ db
src/Distribution/Simple/Hpc.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Hpc -- Copyright   :  Thomas Tuegel 2011@@ -13,103 +16,99 @@ -- This module provides functions for locating various HPC-related paths and -- a function for adding the necessary options to a PackageDescription to -- build test suites with HPC enabled.- module Distribution.Simple.Hpc-    ( Way(..), guessWay-    , htmlDir-    , mixDir-    , tixDir-    , tixFilePath-    , markupPackage-    , markupTest-    ) where+  ( Way (..)+  , guessWay+  , htmlDir+  , mixDir+  , tixDir+  , tixFilePath+  , HPCMarkupInfo (..)+  , markupPackage+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Types.UnqualComponentName-import Distribution.ModuleName ( main )-import qualified Distribution.PackageDescription as PD+import Distribution.ModuleName (ModuleName, main) import Distribution.PackageDescription-    ( Library(..)-    , TestSuite(..)-    , testModules-    )+  ( TestSuite (..)+  , testModules+  )+import qualified Distribution.PackageDescription as PD import Distribution.Pretty-import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )+import Distribution.Simple.LocalBuildInfo+  ( LocalBuildInfo (..)+  , interpretSymbolicPathLBI+  , mbWorkDirLBI+  ) import Distribution.Simple.Program-    ( hpcProgram-    , requireProgramVersion-    )-import Distribution.Simple.Program.Hpc ( markup, union )-import Distribution.Simple.Utils ( notice )-import Distribution.Version ( anyVersion )-import Distribution.Verbosity ( Verbosity() )-import System.Directory ( createDirectoryIfMissing, doesFileExist )-import System.FilePath+  ( hpcProgram+  , requireProgramVersion+  )+import Distribution.Simple.Program.Hpc (markup, union)+import Distribution.Simple.Utils (notice)+import Distribution.Types.UnqualComponentName+import Distribution.Utils.Path+import Distribution.Verbosity (Verbosity ())+import Distribution.Version (anyVersion) +import System.Directory (createDirectoryIfMissing, doesFileExist)+ -- ------------------------------------------------------------------------- -- Haskell Program Coverage -data Way = Vanilla | Prof | Dyn+data Way = Vanilla | Prof | Dyn | ProfDyn   deriving (Bounded, Enum, Eq, Read, Show) -hpcDir :: FilePath  -- ^ \"dist/\" prefix-       -> Way-       -> FilePath  -- ^ Directory containing component's HPC .mix files-hpcDir distPref way = distPref </> "hpc" </> wayDir+hpcDir+  :: SymbolicPath Pkg (Dir Dist)+  -- ^ \"dist/\" prefix+  -> Way+  -> SymbolicPath Pkg (Dir Artifacts)+  -- ^ Directory containing component's HPC .mix files+hpcDir distPref way = distPref </> makeRelativePathEx ("hpc" </> wayDir)   where     wayDir = case way of       Vanilla -> "vanilla"       Prof -> "prof"       Dyn -> "dyn"+      ProfDyn -> "prof_dyn" -mixDir :: FilePath  -- ^ \"dist/\" prefix-       -> Way-       -> FilePath  -- ^ Component name-       -> FilePath  -- ^ Directory containing test suite's .mix files-mixDir distPref way name = hpcDir distPrefBuild way </> "mix" </> name- where-  -- This is a hack for HPC over test suites, needed to match the directory-  -- where HPC saves and reads .mix files when the main library of the same-  -- package is being processed, perhaps in a previous cabal run (#5213).-  -- E.g., @distPref@ may be-  -- @./dist-newstyle/build/x86_64-linux/ghc-9.0.1/cabal-gh5213-0.1/t/tests@-  -- but the path where library mix files reside has two less components-  -- at the end (@t/tests@) and this reduced path needs to be passed to-  -- both @hpc@ and @ghc@. For non-default optimization levels, the path-  -- suffix is one element longer and the extra path element needs-  -- to be preserved.-  distPrefElements = splitDirectories distPref-  distPrefBuild = case drop (length distPrefElements - 3) distPrefElements of-    ["t", _, "noopt"] ->-      joinPath $ take (length distPrefElements - 3) distPrefElements-                 ++ ["noopt"]-    ["t", _, "opt"] ->-      joinPath $ take (length distPrefElements - 3) distPrefElements-                 ++ ["opt"]-    [_, "t", _] ->-      joinPath $ take (length distPrefElements - 2) distPrefElements-    _ -> distPref+mixDir+  :: SymbolicPath Pkg (Dir Dist)+  -- ^ \"dist/\" prefix+  -> Way+  -> SymbolicPath Pkg (Dir Mix)+  -- ^ Directory containing test suite's .mix files+mixDir distPref way = hpcDir distPref way </> makeRelativePathEx "mix" -tixDir :: FilePath  -- ^ \"dist/\" prefix-       -> Way-       -> FilePath  -- ^ Component name-       -> FilePath  -- ^ Directory containing test suite's .tix files-tixDir distPref way name = hpcDir distPref way </> "tix" </> name+tixDir+  :: SymbolicPath Pkg (Dir Dist)+  -- ^ \"dist/\" prefix+  -> Way+  -> SymbolicPath Pkg (Dir Tix)+  -- ^ Directory containing test suite's .tix files+tixDir distPref way = hpcDir distPref way </> makeRelativePathEx "tix"  -- | Path to the .tix file containing a test suite's sum statistics.-tixFilePath :: FilePath     -- ^ \"dist/\" prefix-            -> Way-            -> FilePath     -- ^ Component name-            -> FilePath     -- ^ Path to test suite's .tix file-tixFilePath distPref way name = tixDir distPref way name </> name <.> "tix"+tixFilePath+  :: SymbolicPath Pkg (Dir Dist)+  -- ^ \"dist/\" prefix+  -> Way+  -> FilePath+  -- ^ Component name+  -> SymbolicPath Pkg File+  -- ^ Path to test suite's .tix file+tixFilePath distPref way name = tixDir distPref way </> makeRelativePathEx (name <.> "tix") -htmlDir :: FilePath     -- ^ \"dist/\" prefix-        -> Way-        -> FilePath     -- ^ Component name-        -> FilePath     -- ^ Path to test suite's HTML markup directory-htmlDir distPref way name = hpcDir distPref way </> "html" </> name+htmlDir+  :: SymbolicPath Pkg (Dir Dist)+  -- ^ \"dist/\" prefix+  -> Way+  -> SymbolicPath Pkg (Dir Artifacts)+  -- ^ Path to test suite's HTML markup directory+htmlDir distPref way = hpcDir distPref way </> makeRelativePathEx "html"  -- | Attempt to guess the way the test suites in this package were compiled -- and linked with the library so the correct module interfaces are found.@@ -119,59 +118,72 @@   | withDynExe lbi = Dyn   | otherwise = Vanilla --- | Generate the HTML markup for a test suite.-markupTest :: Verbosity-           -> LocalBuildInfo-           -> FilePath     -- ^ \"dist/\" prefix-           -> String       -- ^ Library name-           -> TestSuite-           -> Library-           -> IO ()-markupTest verbosity lbi distPref libraryName suite library = do-    tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName'-    when tixFileExists $ do-        -- behaviour of 'markup' depends on version, so we need *a* version-        -- but no particular one-        (hpc, hpcVer, _) <- requireProgramVersion verbosity-            hpcProgram anyVersion (withPrograms lbi)-        let htmlDir_ = htmlDir distPref way testName'-        markup hpc hpcVer verbosity-            (tixFilePath distPref way testName') mixDirs-            htmlDir_-            (exposedModules library)-        notice verbosity $ "Test coverage report written to "-                            ++ htmlDir_ </> "hpc_index" <.> "html"-  where-    way = guessWay lbi-    testName' = unUnqualComponentName $ testName suite-    mixDirs = map (mixDir distPref way) [ testName', libraryName ]+-- | Haskell Program Coverage information required to produce a valid HPC+-- report through the `hpc markup` call for the package libraries.+data HPCMarkupInfo = HPCMarkupInfo+  { pathsToLibsArtifacts :: [SymbolicPath Pkg (Dir Artifacts)]+  -- ^ The paths to the library components whose modules are included in the+  -- coverage report+  , libsModulesToInclude :: [ModuleName]+  -- ^ The modules to include in the coverage report+  } --- | Generate the HTML markup for all of a package's test suites.-markupPackage :: Verbosity-              -> LocalBuildInfo-              -> FilePath       -- ^ \"dist/\" prefix-              -> PD.PackageDescription-              -> [TestSuite]-              -> IO ()-markupPackage verbosity lbi distPref pkg_descr suites = do-    let tixFiles = map (tixFilePath distPref way) testNames-    tixFilesExist <- traverse doesFileExist tixFiles-    when (and tixFilesExist) $ do-        -- behaviour of 'markup' depends on version, so we need *a* version-        -- but no particular one-        (hpc, hpcVer, _) <- requireProgramVersion verbosity-            hpcProgram anyVersion (withPrograms lbi)-        let outFile = tixFilePath distPref way libraryName-            htmlDir' = htmlDir distPref way libraryName-            excluded = concatMap testModules suites ++ [ main ]-        createDirectoryIfMissing True $ takeDirectory outFile-        union hpc verbosity tixFiles outFile excluded-        markup hpc hpcVer verbosity outFile mixDirs htmlDir' included-        notice verbosity $ "Package coverage report written to "-                           ++ htmlDir' </> "hpc_index.html"+-- | Generate the HTML markup for a package's test suites.+markupPackage+  :: Verbosity+  -> HPCMarkupInfo+  -> LocalBuildInfo+  -> SymbolicPath Pkg (Dir Dist)+  -- ^ Testsuite \"dist/\" prefix+  -> PD.PackageDescription+  -> [TestSuite]+  -> IO ()+markupPackage verbosity HPCMarkupInfo{pathsToLibsArtifacts, libsModulesToInclude} lbi testDistPref pkg_descr suites = do+  let tixFiles = map (tixFilePath testDistPref way) testNames+      mbWorkDir = mbWorkDirLBI lbi+      i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path+  tixFilesExist <- traverse (doesFileExist . i) tixFiles+  when (and tixFilesExist) $ do+    -- behaviour of 'markup' depends on version, so we need *a* version+    -- but no particular one+    (hpc, hpcVer, _) <-+      requireProgramVersion+        verbosity+        hpcProgram+        anyVersion+        (withPrograms lbi)+    let htmlDir' = htmlDir testDistPref way+    -- The tix file used to generate the report is either the testsuite's+    -- tix file, when there is only one testsuite, or the sum of the tix+    -- files of all testsuites in the package, which gets put under pkgName+    -- for this component (a bit weird)+    -- TODO: cabal-install should pass to Cabal where to put the summed tix+    -- and report, and perhaps even the testsuites from other packages in+    -- the project which are currently not accounted for in the summed+    -- report.+    tixFile <- case suites of+      -- We call 'markupPackage' once for each testsuite to run individually,+      -- to get the coverage report of just the one testsuite+      [oneTest] -> do+        let testName' = unUnqualComponentName $ testName oneTest+        return $+          tixFilePath testDistPref way testName'+      -- And call 'markupPackage' once per `test` invocation with all the+      -- testsuites to run, which results in multiple tix files being considered+      _ -> do+        let excluded = concatMap testModules suites ++ [main]+            pkgName = prettyShow $ PD.package pkg_descr+            summedTixFile = tixFilePath testDistPref way pkgName+        createDirectoryIfMissing True $ i $ takeDirectorySymbolicPath summedTixFile+        union mbWorkDir hpc verbosity tixFiles summedTixFile excluded+        return summedTixFile++    markup mbWorkDir hpc hpcVer verbosity tixFile mixDirs htmlDir' libsModulesToInclude+    notice verbosity $+      "Package coverage report written to "+        ++ i htmlDir'+        </> "hpc_index.html"   where     way = guessWay lbi     testNames = fmap (unUnqualComponentName . testName) suites-    mixDirs = map (mixDir distPref way) $ libraryName : testNames-    included = concatMap (exposedModules) $ PD.allLibraries pkg_descr-    libraryName = prettyShow $ PD.package pkg_descr+    mixDirs = map ((`mixDir` way) . coerceSymbolicPath) pathsToLibsArtifacts
src/Distribution/Simple/Install.hs view
@@ -1,7 +1,11 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Install -- Copyright   :  Isaac Jones 2003-2004@@ -14,247 +18,355 @@ -- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into -- place based on the prefix argument. It does the generic bits and then calls -- compiler-specific functions to do the rest.--module Distribution.Simple.Install (-        install,+module Distribution.Simple.Install+  ( install+  , install_setupHooks+  , installFileGlob   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Types.TargetInfo-import Distribution.Types.LocalBuildInfo+import Distribution.CabalSpecVersion (CabalSpecVersion)++import Distribution.Types.ExecutableScope import Distribution.Types.ForeignLib+import Distribution.Types.LocalBuildInfo import Distribution.Types.PackageDescription+import Distribution.Types.TargetInfo import Distribution.Types.UnqualComponentName-import Distribution.Types.ExecutableScope  import Distribution.Package import Distribution.PackageDescription-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.BuildPaths (haddockName, haddockPref)+import Distribution.Simple.BuildPaths (haddockPath, haddockPref)+import Distribution.Simple.BuildTarget+import Distribution.Simple.Compiler+  ( CompilerFlavor (..)+  , compilerFlavor+  ) import Distribution.Simple.Glob (matchDirFileGlob)+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Setup.Config+import Distribution.Simple.Setup.Copy+  ( CopyFlags (..)+  )+import Distribution.Simple.Setup.Haddock+  ( HaddockTarget (ForDevelopment)+  )+import Distribution.Simple.SetupHooks.Internal+  ( InstallHooks (..)+  )+import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose-         , installDirectoryContents, installOrdinaryFile, isInSearchPath-         , die', info, noticeNoWrap, warn )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), compilerFlavor )-import Distribution.Simple.Setup-         ( CopyFlags(..), fromFlag, HaddockTarget(ForDevelopment) )-import Distribution.Simple.BuildTarget-import Distribution.Utils.Path (getSymbolicPath)+  ( createDirectoryIfMissingVerbose+  , dieWithException+  , info+  , installDirectoryContents+  , installOrdinaryFile+  , isAbsoluteOnAnyPlatform+  , isInSearchPath+  , noticeNoWrap+  , warn+  )+import Distribution.Utils.Path -import qualified Distribution.Simple.GHC   as GHC+import Distribution.Compat.Graph (IsNode (..))+import Distribution.Simple.Errors+import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS-import qualified Distribution.Simple.UHC   as UHC-import qualified Distribution.Simple.HaskellSuite as HaskellSuite-import Distribution.Compat.Graph (IsNode(..))+import Distribution.Simple.Setup.Common+import qualified Distribution.Simple.UHC as UHC  import System.Directory-         ( doesDirectoryExist, doesFileExist )+  ( doesDirectoryExist+  , doesFileExist+  ) import System.FilePath-         ( takeFileName, takeDirectory, (</>), isRelative )+  ( takeDirectory+  , takeFileName+  ) -import Distribution.Verbosity import Distribution.Pretty-         ( prettyShow )+  ( prettyShow+  )+import Distribution.Verbosity --- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\"--- actions.  Move files into place based on the prefix argument.+-- | Perform the \"@.\/setup install@\" and \"@.\/setup copy@\"+--  actions.  Move files into place based on the prefix argument. ----- This does NOT register libraries, you should call 'register'--- to do that.+--  This does NOT register libraries, you should call 'register'+--  to do that.+install+  :: PackageDescription+  -- ^ information from the .cabal file+  -> LocalBuildInfo+  -- ^ information from the configure step+  -> CopyFlags+  -- ^ flags sent to copy or install+  -> IO ()+install = install_setupHooks SetupHooks.noInstallHooks -install :: PackageDescription -- ^information from the .cabal file-        -> LocalBuildInfo -- ^information from the configure step-        -> CopyFlags -- ^flags sent to copy or install-        -> IO ()-install pkg_descr lbi flags = do-  checkHasLibsOrExes-  targets <- readTargetInfos verbosity pkg_descr lbi (copyArgs flags)+install_setupHooks+  :: InstallHooks+  -> PackageDescription+  -- ^ information from the .cabal file+  -> LocalBuildInfo+  -- ^ information from the configure step+  -> CopyFlags+  -- ^ flags sent to copy or install+  -> IO ()+install_setupHooks+  (InstallHooks{installComponentHook})+  pkg_descr+  lbi+  flags = do+    checkHasLibsOrExes+    targets <- readTargetInfos verbosity pkg_descr lbi (copyTargets flags) -  copyPackage verbosity pkg_descr lbi distPref copydest+    copyPackage verbosity pkg_descr lbi distPref copydest -  -- It's not necessary to do these in build-order, but it's harmless-  withNeededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) $ \target ->-    let comp = targetComponent target-        clbi = targetCLBI target-    in copyComponent verbosity pkg_descr lbi comp clbi copydest- where-  distPref  = fromFlag (copyDistPref flags)-  verbosity = fromFlag (copyVerbosity flags)-  copydest  = fromFlag (copyDest flags)+    -- It's not necessary to do these in build-order, but it's harmless+    withNeededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) $ \target -> do+      let comp = targetComponent target+          clbi = targetCLBI target+      copyComponent verbosity pkg_descr lbi comp clbi copydest+      for_ installComponentHook $ \instAction ->+        let inputs =+              SetupHooks.InstallComponentInputs+                { copyFlags = flags+                , localBuildInfo = lbi+                , targetInfo = target+                }+         in instAction inputs+    where+      common = copyCommonFlags flags+      distPref = fromFlag $ setupDistPref common+      verbosity = fromFlag $ setupVerbosity common+      copydest = fromFlag (copyDest flags) -  checkHasLibsOrExes =-    unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $-      die' verbosity "No executables and no library found. Nothing to do."+      checkHasLibsOrExes =+        unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $+          warn verbosity "No executables and no library found. Nothing to do."  -- | Copy package global files.-copyPackage :: Verbosity -> PackageDescription-            -> LocalBuildInfo -> FilePath -> CopyDest -> IO ()+copyPackage+  :: Verbosity+  -> PackageDescription+  -> LocalBuildInfo+  -> SymbolicPath Pkg (Dir Dist)+  -> CopyDest+  -> IO () copyPackage verbosity pkg_descr lbi distPref copydest = do-  let -- This is a bit of a hack, to handle files which are not-      -- per-component (data files and Haddock files.)-      InstallDirs {-         datadir    = dataPref,-         docdir     = docPref,-         htmldir    = htmlPref,-         haddockdir = interfacePref+  let+    -- This is a bit of a hack, to handle files which are not+    -- per-component (data files and Haddock files.)+    InstallDirs+      { datadir = dataPref+      , docdir = docPref+      , htmldir = htmlPref+      , haddockdir = interfacePref       } = absoluteInstallCommandDirs pkg_descr lbi (localUnitId lbi) copydest+    mbWorkDir = mbWorkDirLBI lbi+    i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path    -- Install (package-global) data files-  installDataFiles verbosity pkg_descr dataPref+  installDataFiles verbosity mbWorkDir pkg_descr $ makeSymbolicPath dataPref    -- Install (package-global) Haddock files   -- TODO: these should be done per-library-  docExists <- doesDirectoryExist $ haddockPref ForDevelopment distPref pkg_descr-  info verbosity ("directory " ++ haddockPref ForDevelopment distPref pkg_descr ++-                  " does exist: " ++ show docExists)+  docExists <- doesDirectoryExist $ i $ haddockPref ForDevelopment distPref pkg_descr+  info+    verbosity+    ( "directory "+        ++ getSymbolicPath (haddockPref ForDevelopment distPref pkg_descr)+        ++ " does exist: "+        ++ show docExists+    )    -- TODO: this is a bit questionable, Haddock files really should   -- be per library (when there are convenience libraries.)   when docExists $ do-      createDirectoryIfMissingVerbose verbosity True htmlPref-      installDirectoryContents verbosity-          (haddockPref ForDevelopment distPref pkg_descr) htmlPref-      -- setPermissionsRecursive [Read] htmlPref-      -- The haddock interface file actually already got installed-      -- in the recursive copy, but now we install it where we actually-      -- want it to be (normally the same place). We could remove the-      -- copy in htmlPref first.-      let haddockInterfaceFileSrc  = haddockPref ForDevelopment distPref pkg_descr-                                                   </> haddockName pkg_descr-          haddockInterfaceFileDest = interfacePref </> haddockName pkg_descr-      -- We only generate the haddock interface file for libs, So if the-      -- package consists only of executables there will not be one:-      exists <- doesFileExist haddockInterfaceFileSrc-      when exists $ do-        createDirectoryIfMissingVerbose verbosity True interfacePref-        installOrdinaryFile verbosity haddockInterfaceFileSrc-                                      haddockInterfaceFileDest+    createDirectoryIfMissingVerbose verbosity True htmlPref+    installDirectoryContents+      verbosity+      (i $ haddockPref ForDevelopment distPref pkg_descr)+      htmlPref+    -- setPermissionsRecursive [Read] htmlPref+    -- The haddock interface file actually already got installed+    -- in the recursive copy, but now we install it where we actually+    -- want it to be (normally the same place). We could remove the+    -- copy in htmlPref first.+    let haddockInterfaceFileSrc =+          haddockPref ForDevelopment distPref pkg_descr+            </> makeRelativePathEx (haddockPath pkg_descr)+        haddockInterfaceFileDest = interfacePref </> haddockPath pkg_descr+    -- We only generate the haddock interface file for libs, So if the+    -- package consists only of executables there will not be one:+    exists <- doesFileExist $ i haddockInterfaceFileSrc+    when exists $ do+      createDirectoryIfMissingVerbose verbosity True interfacePref+      installOrdinaryFile+        verbosity+        (i haddockInterfaceFileSrc)+        haddockInterfaceFileDest    let lfiles = licenseFiles pkg_descr   unless (null lfiles) $ do     createDirectoryIfMissingVerbose verbosity True docPref-    for_ lfiles $ \lfile' -> do-      let lfile :: FilePath-          lfile = getSymbolicPath lfile'-      installOrdinaryFile verbosity lfile (docPref </> takeFileName lfile)+    for_ lfiles $ \lfile -> do+      installOrdinaryFile+        verbosity+        (i lfile)+        (docPref </> takeFileName (getSymbolicPath lfile))  -- | Copy files associated with a component.-copyComponent :: Verbosity -> PackageDescription-              -> LocalBuildInfo -> Component -> ComponentLocalBuildInfo-              -> CopyDest-              -> IO ()+copyComponent+  :: Verbosity+  -> PackageDescription+  -> LocalBuildInfo+  -> Component+  -> ComponentLocalBuildInfo+  -> CopyDest+  -> IO () copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do-    let InstallDirs{-            libdir = libPref,-            dynlibdir = dynlibPref,-            includedir = incPref-            } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest-        buildPref = componentBuildDir lbi clbi--    case libName lib of-        LMainLibName  -> noticeNoWrap verbosity ("Installing library in " ++ libPref)-        LSubLibName n -> noticeNoWrap verbosity ("Installing internal library " ++ prettyShow n ++ " in " ++ libPref)+  let InstallDirs+        { libdir = libPref+        , dynlibdir = dynlibPref+        , includedir = incPref+        } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest+      buildPref = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi -    -- install include files for all compilers - they may be needed to compile-    -- haskell files (using the CPP extension)-    installIncludeFiles verbosity (libBuildInfo lib) lbi buildPref incPref+  case libName lib of+    LMainLibName -> noticeNoWrap verbosity ("Installing library in " ++ libPref)+    LSubLibName n -> noticeNoWrap verbosity ("Installing internal library " ++ prettyShow n ++ " in " ++ libPref) -    case compilerFlavor (compiler lbi) of-      GHC   -> GHC.installLib   verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi-      GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi-      UHC   -> UHC.installLib   verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi-      HaskellSuite _ -> HaskellSuite.installLib-                                verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi-      _ -> die' verbosity $ "installing with "-              ++ prettyShow (compilerFlavor (compiler lbi))-              ++ " is not implemented"+  -- install include files for all compilers - they may be needed to compile+  -- haskell files (using the CPP extension)+  installIncludeFiles verbosity (libBuildInfo lib) lbi buildPref incPref +  case compilerFlavor (compiler lbi) of+    GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi+    GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi+    UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi+    _ ->+      dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do-    let InstallDirs{-            flibdir = flibPref,-            includedir = incPref-            } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest-        buildPref = componentBuildDir lbi clbi--    noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref)-    installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref+  let InstallDirs+        { flibdir = flibPref+        , includedir = incPref+        } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest+      buildPref = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi -    case compilerFlavor (compiler lbi) of-      GHC   -> GHC.installFLib   verbosity lbi flibPref buildPref pkg_descr flib-      GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib-      _ -> die' verbosity $ "installing foreign lib with "-              ++ prettyShow (compilerFlavor (compiler lbi))-              ++ " is not implemented"+  noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref)+  installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref +  case compilerFlavor (compiler lbi) of+    GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib+    GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib+    _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do-    let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest-        -- the installers know how to find the actual location of the-        -- binaries-        buildPref = buildDir lbi-        uid = componentUnitId clbi-        pkgid = packageId pkg_descr-        binPref | ExecutablePrivate <- exeScope exe = libexecdir installDirs-                | otherwise = bindir installDirs-        progPrefixPref = substPathTemplate pkgid lbi uid (progPrefix lbi)-        progSuffixPref = substPathTemplate pkgid lbi uid (progSuffix lbi)-        progFix = (progPrefixPref, progSuffixPref)-    noticeNoWrap verbosity ("Installing executable " ++ prettyShow (exeName exe)-                      ++ " in " ++ binPref)-    inPath <- isInSearchPath binPref-    when (not inPath) $-      warn verbosity ("The directory " ++ binPref-                      ++ " is not in the system search path.")-    case compilerFlavor (compiler lbi) of-      GHC   -> GHC.installExe   verbosity lbi binPref buildPref progFix pkg_descr exe-      GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe-      UHC   -> return ()-      HaskellSuite {} -> return ()-      _ -> die' verbosity $ "installing with "-              ++ prettyShow (compilerFlavor (compiler lbi))-              ++ " is not implemented"+  let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest+      -- the installers know how to find the actual location of the+      -- binaries+      buildPref = interpretSymbolicPathLBI lbi $ buildDir lbi+      uid = componentUnitId clbi+      pkgid = packageId pkg_descr+      binPref+        | ExecutablePrivate <- exeScope exe = libexecdir installDirs+        | otherwise = bindir installDirs+      progPrefixPref = substPathTemplate pkgid lbi uid (progPrefix lbi)+      progSuffixPref = substPathTemplate pkgid lbi uid (progSuffix lbi)+      progFix = (progPrefixPref, progSuffixPref)+  noticeNoWrap+    verbosity+    ( "Installing executable "+        ++ prettyShow (exeName exe)+        ++ " in "+        ++ binPref+    )+  inPath <- isInSearchPath binPref+  when (not inPath) $+    warn+      verbosity+      ( "The directory "+          ++ binPref+          ++ " is not in the system search path."+      )+  case compilerFlavor (compiler lbi) of+    GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe+    GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe+    UHC -> return ()+    _ ->+      dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi))  -- Nothing to do for benchmark/testsuite copyComponent _ _ _ (CBench _) _ _ = return () copyComponent _ _ _ (CTest _) _ _ = return ()  -- | Install the files listed in data-files----installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO ()-installDataFiles verbosity pkg_descr destDataDir =-  flip traverse_ (dataFiles pkg_descr) $ \ glob -> do-    let srcDataDirRaw = dataDir pkg_descr-        srcDataDir = if null srcDataDirRaw-          then "."-          else srcDataDirRaw-    files <- matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir glob-    for_ files $ \ file' -> do-      let src = srcDataDir </> file'-          dst = destDataDir </> file'-      createDirectoryIfMissingVerbose verbosity True (takeDirectory dst)-      installOrdinaryFile verbosity src dst+installDataFiles+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> PackageDescription+  -> SymbolicPath Pkg (Dir DataDir)+  -> IO ()+installDataFiles verbosity mbWorkDir pkg_descr destDataDir =+  traverse_+    (installFileGlob verbosity (specVersion pkg_descr) mbWorkDir (srcDataDir, destDataDir))+    (dataFiles pkg_descr)+  where+    srcDataDirRaw = getSymbolicPath $ dataDir pkg_descr+    srcDataDir :: Maybe (SymbolicPath CWD (Dir DataDir))+    srcDataDir+      | null srcDataDirRaw =+          Nothing+      | isAbsoluteOnAnyPlatform srcDataDirRaw =+          Just $ makeSymbolicPath srcDataDirRaw+      | otherwise =+          Just $ fromMaybe sameDirectory mbWorkDir </> makeRelativePathEx srcDataDirRaw +-- | Install the files specified by the given glob pattern.+installFileGlob+  :: Verbosity+  -> CabalSpecVersion+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> (Maybe (SymbolicPath CWD (Dir DataDir)), SymbolicPath Pkg (Dir DataDir))+  -- ^ @(src_dir, dest_dir)@+  -> RelativePath DataDir File+  -- ^ file glob pattern+  -> IO ()+installFileGlob verbosity spec_version mbWorkDir (srcDir, destDir) glob = do+  files <- matchDirFileGlob verbosity spec_version srcDir glob+  for_ files $ \file' -> do+    let src = getSymbolicPath (fromMaybe sameDirectory srcDir </> file')+        dst = interpretSymbolicPath mbWorkDir (destDir </> file')+    createDirectoryIfMissingVerbose verbosity True (takeDirectory dst)+    installOrdinaryFile verbosity src dst+ -- | Install the files listed in install-includes for a library--- installIncludeFiles :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO () installIncludeFiles verbosity libBi lbi buildPref destIncludeDir = do-    let relincdirs = "." : filter isRelative (includeDirs libBi)-        incdirs = [ baseDir lbi </> dir | dir <- relincdirs ]-                  ++ [ buildPref </> dir | dir <- relincdirs ]-    incs <- traverse (findInc incdirs) (installIncludes libBi)-    sequence_-      [ do createDirectoryIfMissingVerbose verbosity True destDir-           installOrdinaryFile verbosity srcFile destFile-      | (relFile, srcFile) <- incs-      , let destFile = destIncludeDir </> relFile-            destDir  = takeDirectory destFile ]+  let relincdirs = sameDirectory : mapMaybe symbolicPathRelative_maybe (includeDirs libBi)+      incdirs =+        [ root </> getSymbolicPath dir+        | -- NB: both baseDir and buildPref are already interpreted,+        -- so we don't need to interpret these paths in the call to findInc.+        dir <- relincdirs+        , root <- [baseDir lbi, buildPref]+        ]+  incs <- traverse (findInc incdirs . getSymbolicPath) (installIncludes libBi)+  sequence_+    [ do+      createDirectoryIfMissingVerbose verbosity True destDir+      installOrdinaryFile verbosity srcFile destFile+    | (relFile, srcFile) <- incs+    , let destFile = destIncludeDir </> relFile+          destDir = takeDirectory destFile+    ]   where-   baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath lbi')-   findInc []         file = die' verbosity ("can't find include file " ++ file)-   findInc (dir:dirs) file = do-     let path = dir </> file-     exists <- doesFileExist path-     if exists then return (file, path) else findInc dirs file+    baseDir lbi' = 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
src/Distribution/Simple/InstallDirs.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.InstallDirs -- Copyright   :  Isaac Jones 2003-2004@@ -22,48 +22,49 @@ -- changing the prefix all other dirs still end up changed appropriately. So it -- provides a 'PathTemplate' type and functions for substituting for these -- templates.--module Distribution.Simple.InstallDirs (-        InstallDirs(..),-        InstallDirTemplates,-        defaultInstallDirs,-        defaultInstallDirs',-        combineInstallDirs,-        absoluteInstallDirs,-        CopyDest(..),-        prefixRelativeInstallDirs,-        substituteInstallDirTemplates,--        PathTemplate,-        PathTemplateVariable(..),-        PathTemplateEnv,-        toPathTemplate,-        fromPathTemplate,-        combinePathTemplate,-        substPathTemplate,-        initialPathTemplateEnv,-        platformTemplateEnv,-        compilerTemplateEnv,-        packageTemplateEnv,-        abiTemplateEnv,-        installDirsTemplateEnv,+module Distribution.Simple.InstallDirs+  ( InstallDirs (..)+  , InstallDirTemplates+  , defaultInstallDirs+  , defaultInstallDirs'+  , combineInstallDirs+  , absoluteInstallDirs+  , CopyDest (..)+  , prefixRelativeInstallDirs+  , substituteInstallDirTemplates+  , PathTemplate+  , PathTemplateVariable (..)+  , PathTemplateEnv+  , toPathTemplate+  , fromPathTemplate+  , combinePathTemplate+  , substPathTemplate+  , initialPathTemplateEnv+  , platformTemplateEnv+  , compilerTemplateEnv+  , packageTemplateEnv+  , abiTemplateEnv+  , installDirsTemplateEnv   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import Distribution.Compat.Environment (lookupEnv)-import Distribution.Pretty-import Distribution.Package-import Distribution.System import Distribution.Compiler+import Distribution.Package+import Distribution.Pretty import Distribution.Simple.InstallDirs.Internal+import Distribution.System  import System.Directory (getAppUserDataDirectory) import System.FilePath-  ( (</>), isPathSeparator-  , pathSeparator, dropDrive-  , takeDirectory )+  ( dropDrive+  , isPathSeparator+  , pathSeparator+  , takeDirectory+  , (</>)+  )  #ifdef mingw32_HOST_OS import qualified Prelude@@ -74,32 +75,32 @@ -- --------------------------------------------------------------------------- -- Installation directories - -- | The directories where we will install files for packages. -- -- We have several different directories for different types of files since -- many systems have conventions whereby different types of files in a package -- are installed in different directories. This is particularly the case on -- Unix style systems.----data InstallDirs dir = InstallDirs {-        prefix       :: dir,-        bindir       :: dir,-        libdir       :: dir,-        libsubdir    :: dir,-        dynlibdir    :: dir,-        flibdir      :: dir, -- ^ foreign libraries-        libexecdir   :: dir,-        libexecsubdir:: dir,-        includedir   :: dir,-        datadir      :: dir,-        datasubdir   :: dir,-        docdir       :: dir,-        mandir       :: dir,-        htmldir      :: dir,-        haddockdir   :: dir,-        sysconfdir   :: dir-    } deriving (Eq, Read, Show, Functor, Generic, Typeable)+data InstallDirs dir = InstallDirs+  { prefix :: dir+  , bindir :: dir+  , libdir :: dir+  , libsubdir :: dir+  , dynlibdir :: dir+  , flibdir :: dir+  -- ^ foreign libraries+  , libexecdir :: dir+  , libexecsubdir :: dir+  , includedir :: dir+  , datadir :: dir+  , datasubdir :: dir+  , docdir :: dir+  , mandir :: dir+  , htmldir :: dir+  , haddockdir :: dir+  , sysconfdir :: dir+  }+  deriving (Eq, Read, Show, Functor, Generic)  instance Binary dir => Binary (InstallDirs dir) instance Structured dir => Structured (InstallDirs dir)@@ -111,38 +112,41 @@ instance Semigroup dir => Semigroup (InstallDirs dir) where   (<>) = gmappend -combineInstallDirs :: (a -> b -> c)-                   -> InstallDirs a-                   -> InstallDirs b-                   -> InstallDirs c-combineInstallDirs combine a b = InstallDirs {-    prefix       = prefix a     `combine` prefix b,-    bindir       = bindir a     `combine` bindir b,-    libdir       = libdir a     `combine` libdir b,-    libsubdir    = libsubdir a  `combine` libsubdir b,-    dynlibdir    = dynlibdir a  `combine` dynlibdir b,-    flibdir      = flibdir a    `combine` flibdir b,-    libexecdir   = libexecdir a `combine` libexecdir b,-    libexecsubdir= libexecsubdir a `combine` libexecsubdir b,-    includedir   = includedir a `combine` includedir b,-    datadir      = datadir a    `combine` datadir b,-    datasubdir   = datasubdir a `combine` datasubdir b,-    docdir       = docdir a     `combine` docdir b,-    mandir       = mandir a     `combine` mandir b,-    htmldir      = htmldir a    `combine` htmldir b,-    haddockdir   = haddockdir a `combine` haddockdir b,-    sysconfdir   = sysconfdir a `combine` sysconfdir b-  }+combineInstallDirs+  :: (a -> b -> c)+  -> InstallDirs a+  -> InstallDirs b+  -> InstallDirs c+combineInstallDirs combine a b =+  InstallDirs+    { prefix = prefix a `combine` prefix b+    , bindir = bindir a `combine` bindir b+    , libdir = libdir a `combine` libdir b+    , libsubdir = libsubdir a `combine` libsubdir b+    , dynlibdir = dynlibdir a `combine` dynlibdir b+    , flibdir = flibdir a `combine` flibdir b+    , libexecdir = libexecdir a `combine` libexecdir b+    , libexecsubdir = libexecsubdir a `combine` libexecsubdir b+    , includedir = includedir a `combine` includedir b+    , datadir = datadir a `combine` datadir b+    , datasubdir = datasubdir a `combine` datasubdir b+    , docdir = docdir a `combine` docdir b+    , mandir = mandir a `combine` mandir b+    , htmldir = htmldir a `combine` htmldir b+    , haddockdir = haddockdir a `combine` haddockdir b+    , sysconfdir = sysconfdir a `combine` sysconfdir b+    }  appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a-appendSubdirs append dirs = dirs {-    libdir     = libdir dirs `append` libsubdir dirs,-    libexecdir = libexecdir dirs `append` libexecsubdir dirs,-    datadir    = datadir dirs `append` datasubdir dirs,-    libsubdir  = error "internal error InstallDirs.libsubdir",-    libexecsubdir = error "internal error InstallDirs.libexecsubdir",-    datasubdir = error "internal error InstallDirs.datasubdir"-  }+appendSubdirs append dirs =+  dirs+    { libdir = libdir dirs `append` libsubdir dirs+    , libexecdir = libexecdir dirs `append` libexecsubdir dirs+    , datadir = datadir dirs `append` datasubdir dirs+    , libsubdir = error "internal error InstallDirs.libsubdir"+    , libexecsubdir = error "internal error InstallDirs.libexecsubdir"+    , datasubdir = error "internal error InstallDirs.datasubdir"+    }  -- | The installation directories in terms of 'PathTemplate's that contain -- variables.@@ -165,7 +169,6 @@ -- -- An additional complication is the need to support relocatable packages on -- systems which support such things, like Windows.--- type InstallDirTemplates = InstallDirs PathTemplate  -- ---------------------------------------------------------------------------@@ -174,56 +177,77 @@ defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates defaultInstallDirs = defaultInstallDirs' False -defaultInstallDirs' :: Bool {- use external internal deps -}-                    -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates+defaultInstallDirs'+  :: Bool {- use external internal deps -}+  -> CompilerFlavor+  -> Bool+  -> Bool+  -> IO InstallDirTemplates defaultInstallDirs' True comp userInstall hasLibs = do   dflt <- defaultInstallDirs' False comp userInstall hasLibs   -- Be a bit more hermetic about per-component installs-  return dflt { datasubdir = toPathTemplate $ "$abi" </> "$libname",-                docdir     = toPathTemplate $ "$datadir" </> "doc" </> "$abi" </> "$libname"-              }+  return+    dflt+      { datasubdir = toPathTemplate $ "$abi" </> "$libname"+      , docdir = toPathTemplate $ "$datadir" </> "doc" </> "$abi" </> "$libname"+      } defaultInstallDirs' False comp userInstall _hasLibs = do   installPrefix <--      if userInstall+    if userInstall       then do         mDir <- lookupEnv "CABAL_DIR"         case mDir of           Nothing -> getAppUserDataDirectory "cabal"           Just dir -> return dir       else case buildOS of-           Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir-                         return (windowsProgramFilesDir </> "Haskell")-           _       -> return "/usr/local"+        Windows -> do+          windowsProgramFilesDir <- getWindowsProgramFilesDir+          return (windowsProgramFilesDir </> "Haskell")+        Haiku -> return "/boot/system/non-packaged"+        _ -> return "/usr/local"   installLibDir <--      case buildOS of+    case buildOS of       Windows -> return "$prefix"-      _       -> return ("$prefix" </> "lib")-  return $ fmap toPathTemplate $ InstallDirs {-      prefix       = installPrefix,-      bindir       = "$prefix" </> "bin",-      libdir       = installLibDir,-      libsubdir    = case comp of-           UHC    -> "$pkgid"-           _other -> "$abi" </> "$libname",-      dynlibdir    = "$libdir" </> case comp of-           UHC    -> "$pkgid"-           _other -> "$abi",-      libexecsubdir= "$abi" </> "$pkgid",-      flibdir      = "$libdir",-      libexecdir   = case buildOS of-        Windows   -> "$prefix" </> "$libname"-        _other    -> "$prefix" </> "libexec",-      includedir   = "$libdir" </> "$libsubdir" </> "include",-      datadir      = case buildOS of-        Windows   -> "$prefix"-        _other    -> "$prefix" </> "share",-      datasubdir   = "$abi" </> "$pkgid",-      docdir       = "$datadir" </> "doc" </> "$abi" </> "$pkgid",-      mandir       = "$datadir" </> "man",-      htmldir      = "$docdir"  </> "html",-      haddockdir   = "$htmldir",-      sysconfdir   = "$prefix" </> "etc"-  }+      _ -> return ("$prefix" </> "lib")+  return $+    fmap toPathTemplate $+      InstallDirs+        { prefix = installPrefix+        , bindir = "$prefix" </> "bin"+        , libdir = installLibDir+        , libsubdir = case comp of+            UHC -> "$pkgid"+            _other -> "$abi" </> "$libname"+        , dynlibdir =+            "$libdir" </> case comp of+              UHC -> "$pkgid"+              _other -> "$abi"+        , libexecsubdir = "$abi" </> "$pkgid"+        , flibdir = "$libdir"+        , libexecdir = case buildOS of+            Windows -> "$prefix" </> "$libname"+            Haiku -> "$libdir"+            _other -> "$prefix" </> "libexec"+        , includedir = case buildOS of+            Haiku -> "$prefix" </> "develop" </> "headers"+            _other -> "$libdir" </> "$libsubdir" </> "include"+        , datadir = case buildOS of+            Windows -> "$prefix"+            Haiku -> "$prefix" </> "data"+            _other -> "$prefix" </> "share"+        , datasubdir = "$abi" </> "$pkgid"+        , docdir = case buildOS of+            Haiku -> "$prefix" </> "documentation"+            _other -> "$datadir" </> "doc" </> "$abi" </> "$pkgid"+        , mandir = case buildOS of+            Haiku -> "$docdir" </> "man"+            _other -> "$datadir" </> "man"+        , htmldir = "$docdir" </> "html"+        , haddockdir = "$htmldir"+        , sysconfdir = case buildOS of+            Haiku -> "boot" </> "system" </> "settings"+            _other -> "$prefix" </> "etc"+        }  -- --------------------------------------------------------------------------- -- Converting directories, absolute or prefix-relative@@ -239,102 +263,113 @@ -- can replace 'prefix' with the 'PrefixVar' and get resulting -- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it -- each to check which paths are relative to the $prefix.----substituteInstallDirTemplates :: PathTemplateEnv-                              -> InstallDirTemplates -> InstallDirTemplates+substituteInstallDirTemplates+  :: PathTemplateEnv+  -> InstallDirTemplates+  -> InstallDirTemplates substituteInstallDirTemplates env dirs = dirs'   where-    dirs' = InstallDirs {-      -- So this specifies exactly which vars are allowed in each template-      prefix     = subst prefix     [],-      bindir     = subst bindir     [prefixVar],-      libdir     = subst libdir     [prefixVar, bindirVar],-      libsubdir  = subst libsubdir  [],-      dynlibdir  = subst dynlibdir  [prefixVar, bindirVar, libdirVar],-      flibdir    = subst flibdir    [prefixVar, bindirVar, libdirVar],-      libexecdir = subst libexecdir prefixBinLibVars,-      libexecsubdir = subst libexecsubdir [],-      includedir = subst includedir prefixBinLibVars,-      datadir    = subst datadir    prefixBinLibVars,-      datasubdir = subst datasubdir [],-      docdir     = subst docdir     prefixBinLibDataVars,-      mandir     = subst mandir     (prefixBinLibDataVars ++ [docdirVar]),-      htmldir    = subst htmldir    (prefixBinLibDataVars ++ [docdirVar]),-      haddockdir = subst haddockdir (prefixBinLibDataVars ++-                                      [docdirVar, htmldirVar]),-      sysconfdir = subst sysconfdir prefixBinLibVars-    }-    subst dir env' = substPathTemplate (env'++env) (dir dirs)+    dirs' =+      InstallDirs+        { -- So this specifies exactly which vars are allowed in each template+          prefix = subst prefix []+        , bindir = subst bindir [prefixVar]+        , libdir = subst libdir [prefixVar, bindirVar]+        , libsubdir = subst libsubdir []+        , dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar]+        , flibdir = subst flibdir [prefixVar, bindirVar, libdirVar]+        , libexecdir = subst libexecdir prefixBinLibVars+        , libexecsubdir = subst libexecsubdir []+        , includedir = subst includedir prefixBinLibVars+        , datadir = subst datadir prefixBinLibVars+        , datasubdir = subst datasubdir []+        , docdir = subst docdir prefixBinLibDataVars+        , mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar])+        , htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar])+        , haddockdir =+            subst+              haddockdir+              ( prefixBinLibDataVars+                  ++ [docdirVar, htmldirVar]+              )+        , sysconfdir = subst sysconfdir prefixBinLibVars+        }+    subst dir env' = substPathTemplate (env' ++ env) (dir dirs) -    prefixVar        = (PrefixVar,     prefix     dirs')-    bindirVar        = (BindirVar,     bindir     dirs')-    libdirVar        = (LibdirVar,     libdir     dirs')-    libsubdirVar     = (LibsubdirVar,  libsubdir  dirs')-    datadirVar       = (DatadirVar,    datadir    dirs')-    datasubdirVar    = (DatasubdirVar, datasubdir dirs')-    docdirVar        = (DocdirVar,     docdir     dirs')-    htmldirVar       = (HtmldirVar,    htmldir    dirs')+    prefixVar = (PrefixVar, prefix dirs')+    bindirVar = (BindirVar, bindir dirs')+    libdirVar = (LibdirVar, libdir dirs')+    libsubdirVar = (LibsubdirVar, libsubdir dirs')+    datadirVar = (DatadirVar, datadir dirs')+    datasubdirVar = (DatasubdirVar, datasubdir dirs')+    docdirVar = (DocdirVar, docdir dirs')+    htmldirVar = (HtmldirVar, htmldir dirs')     prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar]     prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar]  -- | Convert from abstract install directories to actual absolute ones by -- substituting for all the variables in the abstract paths, to get real -- absolute path.-absoluteInstallDirs :: PackageIdentifier-                    -> UnitId-                    -> CompilerInfo-                    -> CopyDest-                    -> Platform-                    -> InstallDirs PathTemplate-                    -> InstallDirs FilePath+absoluteInstallDirs+  :: PackageIdentifier+  -> UnitId+  -> CompilerInfo+  -> CopyDest+  -> Platform+  -> InstallDirs PathTemplate+  -> InstallDirs FilePath absoluteInstallDirs pkgId libname compilerId copydest platform dirs =-    (case copydest of-       CopyTo destdir -> fmap ((destdir </>) . dropDrive)-       CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir))-       _              -> id)-  . appendSubdirs (</>)-  . fmap fromPathTemplate-  $ substituteInstallDirTemplates env dirs+  ( case copydest of+      CopyTo destdir -> fmap ((destdir </>) . dropDrive)+      CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir))+      _ -> id+  )+    . appendSubdirs (</>)+    . fmap fromPathTemplate+    $ substituteInstallDirTemplates env dirs   where     env = initialPathTemplateEnv pkgId libname compilerId platform     substPrefix pre root path       | pre `isPrefixOf` path = root ++ drop (length pre) path-      | otherwise             = path-+      | otherwise = path --- |The location prefix for the /copy/ command.+-- | The location prefix for the /copy/ command. data CopyDest   = NoCopyDest   | CopyTo FilePath-  | CopyToDb FilePath-  -- ^ when using the ${pkgroot} as prefix. The CopyToDb will-  --   adjust the paths to be relative to the provided package-  --   database when copying / installing.+  | -- | when using the ${pkgroot} as prefix. The CopyToDb will+    --   adjust the paths to be relative to the provided package+    --   database when copying / installing.+    CopyToDb FilePath   deriving (Eq, Show, Generic) +-- TODO: are these paths absolute or relative? Relative to what?+ instance Binary CopyDest+instance Structured CopyDest  -- | Check which of the paths are relative to the installation $prefix. -- -- If any of the paths are not relative, ie they are absolute paths, then it -- prevents us from making a relocatable package (also known as a \"prefix -- independent\" package).----prefixRelativeInstallDirs :: PackageIdentifier-                          -> UnitId-                          -> CompilerInfo-                          -> Platform-                          -> InstallDirTemplates-                          -> InstallDirs (Maybe FilePath)+prefixRelativeInstallDirs+  :: PackageIdentifier+  -> UnitId+  -> CompilerInfo+  -> Platform+  -> InstallDirTemplates+  -> InstallDirs (Maybe FilePath) prefixRelativeInstallDirs pkgId libname compilerId platform dirs =-    fmap relative-  . appendSubdirs combinePathTemplate-  $ -- substitute the path template into each other, except that we map+  fmap relative+    . appendSubdirs combinePathTemplate+    $ substituteInstallDirTemplates -- substitute the path template into each other, except that we map     -- \$prefix back to $prefix. We're trying to end up with templates that     -- mention no vars except $prefix.-    substituteInstallDirTemplates env dirs {-      prefix = PathTemplate [Variable PrefixVar]-    }+      env+      dirs+        { prefix = PathTemplate [Variable PrefixVar]+        }   where     env = initialPathTemplateEnv pkgId libname compilerId platform @@ -342,19 +377,18 @@     -- path by stripping off $prefix/ or $prefix     relative dir = case dir of       PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs)-    relative' (Variable PrefixVar : Ordinary (s:rest) : rest')-                      | isPathSeparator s = Just (Ordinary rest : rest')+    relative' (Variable PrefixVar : Ordinary (s : rest) : rest')+      | isPathSeparator s = Just (Ordinary rest : rest')     relative' (Variable PrefixVar : rest) = Just rest-    relative' _                           = Nothing+    relative' _ = Nothing  -- --------------------------------------------------------------------------- -- Path templates  -- | An abstract path, possibly containing variables that need to be -- substituted for to get a real 'FilePath'.--- newtype PathTemplate = PathTemplate [PathComponent]-  deriving (Eq, Ord, Generic, Typeable)+  deriving (Eq, Ord, Generic)  instance Binary PathTemplate instance Structured PathTemplate@@ -362,15 +396,14 @@ type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]  -- | Convert a 'FilePath' to a 'PathTemplate' including any template vars.--- toPathTemplate :: FilePath -> PathTemplate-toPathTemplate fp = PathTemplate+toPathTemplate fp =+  PathTemplate     . fromMaybe (error $ "panic! toPathTemplate " ++ show fp)     . readMaybe -- TODO: eradicateNoParse     $ fp  -- | Convert back to a path, any remaining vars are included--- fromPathTemplate :: PathTemplate -> FilePath fromPathTemplate (PathTemplate template) = show template @@ -380,71 +413,80 @@  substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate substPathTemplate environment (PathTemplate template) =-    PathTemplate (concatMap subst template)--    where subst component@(Ordinary _) = [component]-          subst component@(Variable variable) =-              case lookup variable environment of-                  Just (PathTemplate components) -> components-                  Nothing                        -> [component]+  PathTemplate (concatMap subst template)+  where+    subst component@(Ordinary _) = [component]+    subst component@(Variable variable) =+      case lookup variable environment of+        Just (PathTemplate components) -> components+        Nothing -> [component]  -- | The initial environment has all the static stuff but no paths-initialPathTemplateEnv :: PackageIdentifier-                       -> UnitId-                       -> CompilerInfo-                       -> Platform-                       -> PathTemplateEnv+initialPathTemplateEnv+  :: PackageIdentifier+  -> UnitId+  -> CompilerInfo+  -> Platform+  -> PathTemplateEnv initialPathTemplateEnv pkgId libname compiler platform =-     packageTemplateEnv  pkgId libname-  ++ compilerTemplateEnv compiler-  ++ platformTemplateEnv platform-  ++ abiTemplateEnv compiler platform+  packageTemplateEnv pkgId libname+    ++ compilerTemplateEnv compiler+    ++ platformTemplateEnv platform+    ++ abiTemplateEnv compiler platform  packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv packageTemplateEnv pkgId uid =-  [(PkgNameVar,  PathTemplate [Ordinary $ prettyShow (packageName pkgId)])-  ,(PkgVerVar,   PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)])-  -- Invariant: uid is actually a HashedUnitId.  Hard to enforce because-  -- it's an API change.-  ,(LibNameVar,  PathTemplate [Ordinary $ prettyShow uid])-  ,(PkgIdVar,    PathTemplate [Ordinary $ prettyShow pkgId])+  [ (PkgNameVar, PathTemplate [Ordinary $ prettyShow (packageName pkgId)])+  , (PkgVerVar, PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)])+  , -- Invariant: uid is actually a HashedUnitId.  Hard to enforce because+    -- it's an API change.+    (LibNameVar, PathTemplate [Ordinary $ prettyShow uid])+  , (PkgIdVar, PathTemplate [Ordinary $ prettyShow pkgId])   ]  compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv compilerTemplateEnv compiler =-  [(CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)])+  [ (CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)])   ]  platformTemplateEnv :: Platform -> PathTemplateEnv platformTemplateEnv (Platform arch os) =-  [(OSVar,       PathTemplate [Ordinary $ prettyShow os])-  ,(ArchVar,     PathTemplate [Ordinary $ prettyShow arch])+  [ (OSVar, PathTemplate [Ordinary $ prettyShow os])+  , (ArchVar, PathTemplate [Ordinary $ prettyShow arch])   ]  abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv abiTemplateEnv compiler (Platform arch os) =-  [(AbiVar,      PathTemplate [Ordinary $ prettyShow arch ++ '-':prettyShow os ++-                                          '-':prettyShow (compilerInfoId compiler) ++-                                          case compilerInfoAbiTag compiler of-                                            NoAbiTag   -> ""-                                            AbiTag tag -> '-':tag])-  ,(AbiTagVar,   PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)])+  [+    ( AbiVar+    , PathTemplate+        [ Ordinary $+            prettyShow arch+              ++ '-'+              : prettyShow os+              ++ '-'+              : prettyShow (compilerInfoId compiler)+              ++ case compilerInfoAbiTag compiler of+                NoAbiTag -> ""+                AbiTag tag -> '-' : tag+        ]+    )+  , (AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)])   ]  installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv installDirsTemplateEnv dirs =-  [(PrefixVar,     prefix     dirs)-  ,(BindirVar,     bindir     dirs)-  ,(LibdirVar,     libdir     dirs)-  ,(LibsubdirVar,  libsubdir  dirs)-  ,(DynlibdirVar,  dynlibdir  dirs)-  ,(DatadirVar,    datadir    dirs)-  ,(DatasubdirVar, datasubdir dirs)-  ,(DocdirVar,     docdir     dirs)-  ,(HtmldirVar,    htmldir    dirs)+  [ (PrefixVar, prefix dirs)+  , (BindirVar, bindir dirs)+  , (LibdirVar, libdir dirs)+  , (LibsubdirVar, libsubdir dirs)+  , (DynlibdirVar, dynlibdir dirs)+  , (DatadirVar, datadir dirs)+  , (DatasubdirVar, datasubdir dirs)+  , (DocdirVar, docdir dirs)+  , (HtmldirVar, htmldir dirs)   ] - -- --------------------------------------------------------------------------- -- Parsing and showing path templates: @@ -458,13 +500,16 @@   show (PathTemplate template) = show (show template)  instance Read PathTemplate where-  readsPrec p s = [ (PathTemplate template, s')-                  | (path, s')     <- readsPrec p s-                  , (template, "") <- reads path ]+  readsPrec p s =+    [ (PathTemplate template, s')+    | (path, s') <- readsPrec p s+    , (template, "") <- reads path+    ]  -- --------------------------------------------------------------------------- -- Internal utilities +{- FOURMOLU_DISABLE -} getWindowsProgramFilesDir :: IO FilePath getWindowsProgramFilesDir = do #ifdef mingw32_HOST_OS@@ -473,6 +518,7 @@   let m = Nothing #endif   return (fromMaybe "C:\\Program Files" m)+{- FOURMOLU_ENABLE -}  #ifdef mingw32_HOST_OS shGetFolderPath :: CInt -> IO (Maybe FilePath)@@ -490,7 +536,8 @@ -- csidl_PROGRAM_FILES_COMMON :: CInt -- csidl_PROGRAM_FILES_COMMON = 0x002b -#ifdef x86_64_HOST_ARCH+{- FOURMOLU_DISABLE -}+#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) #define CALLCONV ccall #else #define CALLCONV stdcall@@ -504,3 +551,4 @@                               -> CWString                               -> Prelude.IO CInt #endif+{- FOURMOLU_ENABLE -}
src/Distribution/Simple/InstallDirs/Internal.hs view
@@ -1,127 +1,159 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+ module Distribution.Simple.InstallDirs.Internal-  ( PathComponent(..)-  , PathTemplateVariable(..)+  ( PathComponent (..)+  , PathTemplateVariable (..)   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -data PathComponent =-       Ordinary FilePath-     | Variable PathTemplateVariable-     deriving (Eq, Ord, Generic, Typeable)+data PathComponent+  = Ordinary FilePath+  | Variable PathTemplateVariable+  deriving (Eq, Ord, Generic)  instance Binary PathComponent instance Structured PathComponent -data PathTemplateVariable =-       PrefixVar     -- ^ The @$prefix@ path variable-     | BindirVar     -- ^ The @$bindir@ path variable-     | LibdirVar     -- ^ The @$libdir@ path variable-     | LibsubdirVar  -- ^ The @$libsubdir@ path variable-     | DynlibdirVar  -- ^ The @$dynlibdir@ path variable-     | DatadirVar    -- ^ The @$datadir@ path variable-     | DatasubdirVar -- ^ The @$datasubdir@ path variable-     | DocdirVar     -- ^ The @$docdir@ path variable-     | HtmldirVar    -- ^ The @$htmldir@ path variable-     | PkgNameVar    -- ^ The @$pkg@ package name path variable-     | PkgVerVar     -- ^ The @$version@ package version path variable-     | PkgIdVar      -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@-     | LibNameVar    -- ^ The @$libname@ path variable-     | CompilerVar   -- ^ The compiler name and version, eg @ghc-6.6.1@-     | OSVar         -- ^ The operating system name, eg @windows@ or @linux@-     | ArchVar       -- ^ The CPU architecture name, eg @i386@ or @x86_64@-     | AbiVar        -- ^ The compiler's ABI identifier,-                     ---  $arch-$os-$compiler-$abitag-     | AbiTagVar     -- ^ The optional ABI tag for the compiler-     | ExecutableNameVar -- ^ The executable name; used in shell wrappers-     | TestSuiteNameVar   -- ^ The name of the test suite being run-     | TestSuiteResultVar -- ^ The result of the test suite being run, eg-                          -- @pass@, @fail@, or @error@.-     | BenchmarkNameVar   -- ^ The name of the benchmark being run-  deriving (Eq, Ord, Generic, Typeable)+data PathTemplateVariable+  = -- | The @$prefix@ path variable+    PrefixVar+  | -- | The @$bindir@ path variable+    BindirVar+  | -- | The @$libdir@ path variable+    LibdirVar+  | -- | The @$libsubdir@ path variable+    LibsubdirVar+  | -- | The @$dynlibdir@ path variable+    DynlibdirVar+  | -- | The @$datadir@ path variable+    DatadirVar+  | -- | The @$datasubdir@ path variable+    DatasubdirVar+  | -- | The @$docdir@ path variable+    DocdirVar+  | -- | The @$htmldir@ path variable+    HtmldirVar+  | -- | The @$pkg@ package name path variable+    PkgNameVar+  | -- | The @$version@ package version path variable+    PkgVerVar+  | -- | The @$pkgid@ package Id path variable, eg @foo-1.0@+    PkgIdVar+  | -- | The @$libname@ path variable+    LibNameVar+  | -- | The compiler name and version, eg @ghc-6.6.1@+    CompilerVar+  | -- | The operating system name, eg @windows@ or @linux@+    OSVar+  | -- | The CPU architecture name, eg @i386@ or @x86_64@+    ArchVar+  | -- | The compiler's ABI identifier,+    AbiVar+  | ---  $arch-$os-$compiler-$abitag +    -- | The optional ABI tag for the compiler+    AbiTagVar+  | -- | The executable name; used in shell wrappers+    ExecutableNameVar+  | -- | The name of the test suite being run+    TestSuiteNameVar+  | -- | The result of the test suite being run, eg+    -- @pass@, @fail@, or @error@.+    TestSuiteResultVar+  | -- | The name of the benchmark being run+    BenchmarkNameVar+  deriving (Eq, Ord, Generic)+ instance Binary PathTemplateVariable instance Structured PathTemplateVariable  instance Show PathTemplateVariable where-  show PrefixVar     = "prefix"-  show LibNameVar    = "libname"-  show BindirVar     = "bindir"-  show LibdirVar     = "libdir"-  show LibsubdirVar  = "libsubdir"-  show DynlibdirVar  = "dynlibdir"-  show DatadirVar    = "datadir"+  show PrefixVar = "prefix"+  show LibNameVar = "libname"+  show BindirVar = "bindir"+  show LibdirVar = "libdir"+  show LibsubdirVar = "libsubdir"+  show DynlibdirVar = "dynlibdir"+  show DatadirVar = "datadir"   show DatasubdirVar = "datasubdir"-  show DocdirVar     = "docdir"-  show HtmldirVar    = "htmldir"-  show PkgNameVar    = "pkg"-  show PkgVerVar     = "version"-  show PkgIdVar      = "pkgid"-  show CompilerVar   = "compiler"-  show OSVar         = "os"-  show ArchVar       = "arch"-  show AbiTagVar     = "abitag"-  show AbiVar        = "abi"+  show DocdirVar = "docdir"+  show HtmldirVar = "htmldir"+  show PkgNameVar = "pkg"+  show PkgVerVar = "version"+  show PkgIdVar = "pkgid"+  show CompilerVar = "compiler"+  show OSVar = "os"+  show ArchVar = "arch"+  show AbiTagVar = "abitag"+  show AbiVar = "abi"   show ExecutableNameVar = "executablename"-  show TestSuiteNameVar   = "test-suite"+  show TestSuiteNameVar = "test-suite"   show TestSuiteResultVar = "result"-  show BenchmarkNameVar   = "benchmark"+  show BenchmarkNameVar = "benchmark"  instance Read PathTemplateVariable where   readsPrec _ s =-    take 1-    [ (var, drop (length varStr) s)-    | (varStr, var) <- vars-    , varStr `isPrefixOf` s ]-    -- NB: order matters! Longer strings first-    where vars = [("prefix",     PrefixVar)-                 ,("bindir",     BindirVar)-                 ,("libdir",     LibdirVar)-                 ,("libsubdir",  LibsubdirVar)-                 ,("dynlibdir",  DynlibdirVar)-                 ,("datadir",    DatadirVar)-                 ,("datasubdir", DatasubdirVar)-                 ,("docdir",     DocdirVar)-                 ,("htmldir",    HtmldirVar)-                 ,("pkgid",      PkgIdVar)-                 ,("libname",    LibNameVar)-                 ,("pkgkey",     LibNameVar) -- backwards compatibility-                 ,("pkg",        PkgNameVar)-                 ,("version",    PkgVerVar)-                 ,("compiler",   CompilerVar)-                 ,("os",         OSVar)-                 ,("arch",       ArchVar)-                 ,("abitag",     AbiTagVar)-                 ,("abi",        AbiVar)-                 ,("executablename", ExecutableNameVar)-                 ,("test-suite", TestSuiteNameVar)-                 ,("result", TestSuiteResultVar)-                 ,("benchmark", BenchmarkNameVar)]+    take+      1+      [ (var, drop (length varStr) s)+      | (varStr, var) <- vars+      , varStr `isPrefixOf` s+      ]+    where+      -- NB: order matters! Longer strings first+      vars =+        [ ("prefix", PrefixVar)+        , ("bindir", BindirVar)+        , ("libdir", LibdirVar)+        , ("libsubdir", LibsubdirVar)+        , ("dynlibdir", DynlibdirVar)+        , ("datadir", DatadirVar)+        , ("datasubdir", DatasubdirVar)+        , ("docdir", DocdirVar)+        , ("htmldir", HtmldirVar)+        , ("pkgid", PkgIdVar)+        , ("libname", LibNameVar)+        , ("pkgkey", LibNameVar) -- backwards compatibility+        , ("pkg", PkgNameVar)+        , ("version", PkgVerVar)+        , ("compiler", CompilerVar)+        , ("os", OSVar)+        , ("arch", ArchVar)+        , ("abitag", AbiTagVar)+        , ("abi", AbiVar)+        , ("executablename", ExecutableNameVar)+        , ("test-suite", TestSuiteNameVar)+        , ("result", TestSuiteResultVar)+        , ("benchmark", BenchmarkNameVar)+        ]  instance Show PathComponent where   show (Ordinary path) = path-  show (Variable var)  = '$':show var+  show (Variable var) = '$' : show var   showList = foldr (\x -> (shows x .)) id  instance Read PathComponent where   -- for some reason we collapse multiple $ symbols here   readsPrec _ = lex0-    where lex0 [] = []-          lex0 ('$':'$':s') = lex0 ('$':s')-          lex0 ('$':s') = case [ (Variable var, s'')-                               | (var, s'') <- reads s' ] of-                            [] -> lex1 "$" s'-                            ok -> ok-          lex0 s' = lex1 [] s'-          lex1 ""  ""      = []-          lex1 acc ""      = [(Ordinary (reverse acc), "")]-          lex1 acc ('$':'$':s) = lex1 acc ('$':s)-          lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)]-          lex1 acc (c:s)   = lex1 (c:acc) s-  readList [] = [([],"")]-  readList s  = [ (component:components, s'')-                | (component, s') <- reads s-                , (components, s'') <- readList s' ]+    where+      lex0 [] = []+      lex0 ('$' : '$' : s') = lex0 ('$' : s')+      lex0 ('$' : s') = case [ (Variable var, s'')+                             | (var, s'') <- reads s'+                             ] of+        [] -> lex1 "$" s'+        ok -> ok+      lex0 s' = lex1 [] s'+      lex1 "" "" = []+      lex1 acc "" = [(Ordinary (reverse acc), "")]+      lex1 acc ('$' : '$' : s) = lex1 acc ('$' : s)+      lex1 acc ('$' : s) = [(Ordinary (reverse acc), '$' : s)]+      lex1 acc (c : s) = lex1 (c : acc) s+  readList [] = [([], "")]+  readList s =+    [ (component : components, s'')+    | (component, s') <- reads s+    , (components, s'') <- readList s'+    ]
src/Distribution/Simple/LocalBuildInfo.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.LocalBuildInfo -- Copyright   :  Isaac Jones 2003-2004@@ -18,166 +20,231 @@ -- programs, the package database to use and a bunch of miscellaneous configure -- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets -- passed in to very many subsequent build actions.--module Distribution.Simple.LocalBuildInfo (-        LocalBuildInfo(..),-        localComponentId,-        localUnitId,-        localCompatPackageKey,+module Distribution.Simple.LocalBuildInfo+  ( LocalBuildInfo (..)+  , localComponentId+  , localUnitId+  , localCompatPackageKey -        -- * Buildable package components-        Component(..),-        ComponentName(..),-        LibraryName(..),-        defaultLibName,-        showComponentName,-        componentNameString,-        ComponentLocalBuildInfo(..),-        componentBuildDir,-        foldComponent,-        componentName,-        componentBuildInfo,-        componentBuildable,-        pkgComponents,-        pkgBuildableComponents,-        lookupComponent,-        getComponent,-        allComponentsInBuildOrder,-        depLibraryPaths,-        allLibModules,+    -- * Convenience accessors+  , buildDir+  , packageRoot+  , progPrefix+  , progSuffix+  , interpretSymbolicPathLBI+  , mbWorkDirLBI+  , absoluteWorkingDirLBI+  , buildWays -        withAllComponentsInBuildOrder,-        withLibLBI,-        withExeLBI,-        withBenchLBI,-        withTestLBI,-        enabledTestLBIs,-        enabledBenchLBIs,+    -- * Buildable package components+  , Component (..)+  , ComponentName (..)+  , LibraryName (..)+  , defaultLibName+  , showComponentName+  , componentNameString+  , ComponentLocalBuildInfo (..)+  , componentBuildDir+  , foldComponent+  , componentName+  , componentBuildInfo+  , componentBuildable+  , pkgComponents+  , pkgBuildableComponents+  , lookupComponent+  , getComponent+  , allComponentsInBuildOrder+  , depLibraryPaths+  , allLibModules+  , withAllComponentsInBuildOrder+  , withLibLBI+  , withExeLBI+  , withBenchLBI+  , withTestLBI+  , enabledTestLBIs+  , enabledBenchLBIs -        -- * Installation directories-        module Distribution.Simple.InstallDirs,-        absoluteInstallDirs, prefixRelativeInstallDirs,-        absoluteInstallCommandDirs,-        absoluteComponentInstallDirs, prefixRelativeComponentInstallDirs,-        substPathTemplate,+    -- * Installation directories+  , module Distribution.Simple.InstallDirs+  , absoluteInstallDirs+  , prefixRelativeInstallDirs+  , absoluteInstallCommandDirs+  , absoluteComponentInstallDirs+  , prefixRelativeComponentInstallDirs+  , substPathTemplate   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import Distribution.Types.Component-import Distribution.Types.PackageId-import Distribution.Types.UnitId-import Distribution.Types.ComponentName-import Distribution.Types.UnqualComponentName-import Distribution.Types.PackageDescription import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.ComponentName import Distribution.Types.LocalBuildInfo+import Distribution.Types.PackageDescription+import Distribution.Types.PackageId import Distribution.Types.TargetInfo+import Distribution.Types.UnitId+import Distribution.Types.UnqualComponentName -import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs,-                                               prefixRelativeInstallDirs,-                                               substPathTemplate, )-import qualified Distribution.Simple.InstallDirs as InstallDirs-import Distribution.PackageDescription+import qualified Distribution.Compat.Graph as Graph import qualified Distribution.InstalledPackageInfo as Installed-import Distribution.Package import Distribution.ModuleName+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Pretty import Distribution.Simple.Compiler+import Distribution.Simple.Flag+import Distribution.Simple.InstallDirs hiding+  ( absoluteInstallDirs+  , prefixRelativeInstallDirs+  , substPathTemplate+  )+import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.PackageIndex+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Config import Distribution.Simple.Utils-import Distribution.Pretty-import qualified Distribution.Compat.Graph as Graph+import Distribution.Utils.Path  import Data.List (stripPrefix)-import System.FilePath--import System.Directory (doesDirectoryExist, canonicalizePath)+import qualified System.Directory as Directory+  ( canonicalizePath+  , doesDirectoryExist+  )  -- ----------------------------------------------------------------------------- -- Configuration information of buildable components -componentBuildDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath+componentBuildDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Build) -- For now, we assume that libraries/executables/test-suites/benchmarks -- are only ever built once.  With Backpack, we need a special case for -- libraries so that we can handle building them multiple times.-componentBuildDir lbi clbi-    = buildDir lbi </>-        case componentLocalName clbi of-            CLibName LMainLibName ->-                if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi)-                    then ""-                    else prettyShow (componentUnitId clbi)-            CLibName (LSubLibName s) ->-                if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi)-                    then unUnqualComponentName s-                    else prettyShow (componentUnitId clbi)-            CFLibName s  -> unUnqualComponentName s-            CExeName s   -> unUnqualComponentName s-            CTestName s  -> unUnqualComponentName s-            CBenchName s -> unUnqualComponentName s+componentBuildDir lbi clbi =+  (buildDir lbi </>) $+    makeRelativePathEx $+      case componentLocalName clbi of+        CLibName LMainLibName ->+          if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi)+            then ""+            else prettyShow (componentUnitId clbi)+        CLibName (LSubLibName s) ->+          if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi)+            then unUnqualComponentName s+            else prettyShow (componentUnitId clbi)+        CFLibName s -> unUnqualComponentName s+        CExeName s -> unUnqualComponentName s+        CTestName s -> unUnqualComponentName s+        CBenchName s -> unUnqualComponentName s +-- | Interpret a symbolic path with respect to the working directory+-- stored in 'LocalBuildInfo'.+--+-- Use this before directly interacting with the file system.+--+-- NB: when invoking external programs (such as @GHC@), it is preferable to set+-- the working directory of the process rather than calling this function, as+-- this function will turn relative paths into absolute paths if the working+-- directory is an absolute path. This can degrade error messages, or worse,+-- break the behaviour entirely (because the program might expect certain paths+-- to be relative).+--+-- See Note [Symbolic paths] in Distribution.Utils.Path+interpretSymbolicPathLBI :: LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath+interpretSymbolicPathLBI lbi =+  interpretSymbolicPath (mbWorkDirLBI lbi)++-- | Retrieve an optional working directory from 'LocalBuildInfo'.+mbWorkDirLBI :: LocalBuildInfo -> Maybe (SymbolicPath CWD (Dir Pkg))+mbWorkDirLBI =+  flagToMaybe . setupWorkingDir . configCommonFlags . configFlags++-- | Absolute path to the current working directory.+absoluteWorkingDirLBI :: LocalBuildInfo -> IO (AbsolutePath (Dir Pkg))+absoluteWorkingDirLBI lbi = absoluteWorkingDir (mbWorkDirLBI lbi)+ -- | Perform the action on each enabled 'library' in the package -- description with the 'ComponentLocalBuildInfo'.-withLibLBI :: PackageDescription -> LocalBuildInfo-           -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO ()+withLibLBI+  :: PackageDescription+  -> LocalBuildInfo+  -> (Library -> ComponentLocalBuildInfo -> IO ())+  -> IO () withLibLBI pkg lbi f =-    withAllTargetsInBuildOrder' pkg lbi $ \target ->-        case targetComponent target of-            CLib lib -> f lib (targetCLBI target)-            _ -> return ()+  withAllTargetsInBuildOrder' pkg lbi $ \target ->+    case targetComponent target of+      CLib lib -> f lib (targetCLBI target)+      _ -> return ()  -- | Perform the action on each enabled 'Executable' in the package -- description.  Extended version of 'withExe' that also gives corresponding -- build info.-withExeLBI :: PackageDescription -> LocalBuildInfo-           -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO ()+withExeLBI+  :: PackageDescription+  -> LocalBuildInfo+  -> (Executable -> ComponentLocalBuildInfo -> IO ())+  -> IO () withExeLBI pkg lbi f =-    withAllTargetsInBuildOrder' pkg lbi $ \target ->-        case targetComponent target of-            CExe exe -> f exe (targetCLBI target)-            _ -> return ()+  withAllTargetsInBuildOrder' pkg lbi $ \target ->+    case targetComponent target of+      CExe exe -> f exe (targetCLBI target)+      _ -> return ()  -- | Perform the action on each enabled 'Benchmark' in the package -- description.-withBenchLBI :: PackageDescription -> LocalBuildInfo-            -> (Benchmark -> ComponentLocalBuildInfo -> IO ()) -> IO ()+withBenchLBI+  :: PackageDescription+  -> LocalBuildInfo+  -> (Benchmark -> ComponentLocalBuildInfo -> IO ())+  -> IO () withBenchLBI pkg lbi f =-    sequence_ [ f bench clbi | (bench, clbi) <- enabledBenchLBIs pkg lbi ]+  sequence_ [f bench clbi | (bench, clbi) <- enabledBenchLBIs pkg lbi] -withTestLBI :: PackageDescription -> LocalBuildInfo-            -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO ()+withTestLBI+  :: PackageDescription+  -> LocalBuildInfo+  -> (TestSuite -> ComponentLocalBuildInfo -> IO ())+  -> IO () withTestLBI pkg lbi f =-    sequence_ [ f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi ]+  sequence_ [f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi] -enabledTestLBIs :: PackageDescription -> LocalBuildInfo-             -> [(TestSuite, ComponentLocalBuildInfo)]+enabledTestLBIs+  :: PackageDescription+  -> LocalBuildInfo+  -> [(TestSuite, ComponentLocalBuildInfo)] enabledTestLBIs pkg lbi =-    [ (test, targetCLBI target)-    | target <- allTargetsInBuildOrder' pkg lbi-    , CTest test <- [targetComponent target] ]+  [ (test, targetCLBI target)+  | target <- allTargetsInBuildOrder' pkg lbi+  , CTest test <- [targetComponent target]+  ] -enabledBenchLBIs :: PackageDescription -> LocalBuildInfo-             -> [(Benchmark, ComponentLocalBuildInfo)]+enabledBenchLBIs+  :: PackageDescription+  -> LocalBuildInfo+  -> [(Benchmark, ComponentLocalBuildInfo)] enabledBenchLBIs pkg lbi =-    [ (bench, targetCLBI target)-    | target <- allTargetsInBuildOrder' pkg lbi-    , CBench bench <- [targetComponent target] ]+  [ (bench, targetCLBI target)+  | target <- allTargetsInBuildOrder' pkg lbi+  , CBench bench <- [targetComponent target]+  ]  -- | Perform the action on each buildable 'Library' or 'Executable' (Component) -- in the PackageDescription, subject to the build order specified by the -- 'compBuildOrder' field of the given 'LocalBuildInfo'-withAllComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo-                              -> (Component -> ComponentLocalBuildInfo -> IO ())-                              -> IO ()+withAllComponentsInBuildOrder+  :: PackageDescription+  -> LocalBuildInfo+  -> (Component -> ComponentLocalBuildInfo -> IO ())+  -> IO () withAllComponentsInBuildOrder pkg lbi f =-    withAllTargetsInBuildOrder' pkg lbi $ \target ->-        f (targetComponent target) (targetCLBI target)+  withAllTargetsInBuildOrder' pkg lbi $ \target ->+    f (targetComponent target) (targetCLBI target) -allComponentsInBuildOrder :: LocalBuildInfo-                          -> [ComponentLocalBuildInfo]-allComponentsInBuildOrder lbi =-    Graph.topSort (componentGraph lbi)+allComponentsInBuildOrder+  :: LocalBuildInfo+  -> [ComponentLocalBuildInfo]+allComponentsInBuildOrder (LocalBuildInfo{componentGraph = compGraph}) =+  Graph.topSort compGraph  -- ----------------------------------------------------------------------------- -- A random function that has no business in this module@@ -186,42 +253,62 @@ -- transitive dependencies of the component we are building. -- -- When wanted, and possible, returns paths relative to the installDirs 'prefix'-depLibraryPaths :: Bool -- ^ Building for inplace?-                -> Bool -- ^ Generate prefix-relative library paths-                -> LocalBuildInfo-                -> ComponentLocalBuildInfo -- ^ Component that is being built-                -> IO [FilePath]-depLibraryPaths inplace relative lbi clbi = do-    let pkgDescr    = localPkgDescr lbi-        installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest-        executable  = case clbi of-                        ExeComponentLocalBuildInfo {} -> True-                        _                             -> False-        relDir | executable = bindir installDirs-               | otherwise  = libdir installDirs+depLibraryPaths+  :: Bool+  -- ^ Building for inplace?+  -> Bool+  -- ^ Generate prefix-relative library paths+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -- ^ Component that is being built+  -> IO [FilePath]+depLibraryPaths+  inplace+  relative+  lbi@( LocalBuildInfo+          { localPkgDescr = pkgDescr+          , installedPkgs = installed+          }+        )+  clbi = do+    let installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest+        executable = case clbi of+          ExeComponentLocalBuildInfo{} -> True+          _ -> False+        relDir+          | executable = bindir installDirs+          | otherwise = libdir installDirs -    let -- TODO: this is kind of inefficient-        internalDeps = [ uid-                       | (uid, _) <- componentPackageDeps clbi-                       -- Test that it's internal-                       , sub_target <- allTargetsInBuildOrder' pkgDescr lbi-                       , componentUnitId (targetCLBI (sub_target)) == uid ]-        internalLibs = [ getLibDir (targetCLBI sub_target)-                       | sub_target <- neededTargetsInBuildOrder'-                                        pkgDescr lbi internalDeps ]-    {--    -- This is better, but it doesn't work, because we may be passed a-    -- CLBI which doesn't actually exist, and was faked up when we-    -- were building a test suite/benchmark.  See #3599 for proposal-    -- to fix this.-    let internalCLBIs = filter ((/= componentUnitId clbi) . componentUnitId)-                      . map targetCLBI-                      $ neededTargetsInBuildOrder lbi [componentUnitId clbi]-        internalLibs = map getLibDir internalCLBIs-    -}-        getLibDir sub_clbi-          | inplace    = componentBuildDir lbi sub_clbi-          | otherwise  = dynlibdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest)+    let+      -- TODO: this is kind of inefficient+      internalDeps =+        [ uid+        | (uid, _) <- componentPackageDeps clbi+        , -- Test that it's internal+        sub_target <- allTargetsInBuildOrder' pkgDescr lbi+        , componentUnitId (targetCLBI (sub_target)) == uid+        ]+      internalLibs =+        [ getLibDir (targetCLBI sub_target)+        | sub_target <-+            neededTargetsInBuildOrder'+              pkgDescr+              lbi+              internalDeps+        ]+      {-+      -- This is better, but it doesn't work, because we may be passed a+      -- CLBI which doesn't actually exist, and was faked up when we+      -- were building a test suite/benchmark.  See #3599 for proposal+      -- to fix this.+      let internalCLBIs = filter ((/= componentUnitId clbi) . componentUnitId)+                        . map targetCLBI+                        $ neededTargetsInBuildOrder lbi [componentUnitId clbi]+          internalLibs = map getLibDir internalCLBIs+      -}+      getLibDir sub_clbi+        | inplace = interpretSymbolicPathLBI lbi $ componentBuildDir lbi sub_clbi+        | otherwise = dynlibdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest)      -- Why do we go through all the trouble of a hand-crafting     -- internalLibs, when 'installedPkgs' actually contains the@@ -232,48 +319,54 @@     -- is a moot point if you are using a per-component build,     -- because you never have any internal libraries in this case;     -- they're all external.-    let external_ipkgs = filter is_external (allPackages (installedPkgs lbi))+    let external_ipkgs = filter is_external (allPackages installed)         is_external ipkg = not (installedUnitId ipkg `elem` internalDeps)         -- First look for dynamic libraries in `dynamic-library-dirs`, and use         -- `library-dirs` as a fall back.-        getDynDir pkg  = case Installed.libraryDynDirs pkg of-                           [] -> Installed.libraryDirs pkg-                           d  -> d-        allDepLibDirs  = concatMap getDynDir external_ipkgs+        getDynDir pkg = case Installed.libraryDynDirs pkg of+          [] -> Installed.libraryDirs pkg+          d -> d+        allDepLibDirs = concatMap getDynDir external_ipkgs          allDepLibDirs' = internalLibs ++ allDepLibDirs     allDepLibDirsC <- traverse canonicalizePathNoFail allDepLibDirs' -    let p                = prefix installDirs+    let p = prefix installDirs         prefixRelative l = isJust (stripPrefix p l)         libPaths-          | relative &&-            prefixRelative relDir = map (\l ->-                                          if prefixRelative l-                                             then shortRelativePath relDir l-                                             else l-                                        ) allDepLibDirsC-          | otherwise             = allDepLibDirsC+          | relative+              && prefixRelative relDir =+              map+                ( \l ->+                    if prefixRelative l+                      then shortRelativePath relDir l+                      else l+                )+                allDepLibDirsC+          | otherwise = allDepLibDirsC -    return libPaths-  where-    -- 'canonicalizePath' fails on UNIX when the directory does not exists.-    -- So just don't canonicalize when it doesn't exist.-    canonicalizePathNoFail p = do-      exists <- doesDirectoryExist p-      if exists-         then canonicalizePath p-         else return p+    -- For some reason, this function returns lots of duplicates. Avoid+    -- exceeding `ARG_MAX` (the result of this function is used to populate+    -- `LD_LIBRARY_PATH`) by deduplicating the list.+    return $ ordNub libPaths+    where+      -- 'canonicalizePath' fails on UNIX when the directory does not exists.+      -- So just don't canonicalize when it doesn't exist.+      canonicalizePathNoFail p = do+        exists <- Directory.doesDirectoryExist p+        if exists+          then Directory.canonicalizePath p+          else return p  -- | Get all module names that needed to be built by GHC; i.e., all -- of these 'ModuleName's have interface files associated with them -- that need to be installed. allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName] allLibModules lib clbi =-    ordNub $-    explicitLibModules lib ++-    case clbi of-        LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> map fst insts+  ordNub $+    explicitLibModules lib+      ++ case clbi of+        LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> map fst insts         _ -> []  -- -----------------------------------------------------------------------------@@ -283,49 +376,59 @@ -- assuming that @$libname@ points to the public library (or some fake -- package identifier if there is no public library.)  IF AT ALL -- POSSIBLE, please use 'absoluteComponentInstallDirs' instead.-absoluteInstallDirs :: PackageDescription -> LocalBuildInfo-                    -> CopyDest-                    -> InstallDirs FilePath+absoluteInstallDirs+  :: PackageDescription+  -> LocalBuildInfo+  -> CopyDest+  -> InstallDirs FilePath absoluteInstallDirs pkg lbi copydest =-    absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest+  absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest  -- | See 'InstallDirs.absoluteInstallDirs'.-absoluteComponentInstallDirs :: PackageDescription -> LocalBuildInfo-                             -> UnitId-                             -> CopyDest-                             -> InstallDirs FilePath-absoluteComponentInstallDirs pkg lbi uid copydest =-  InstallDirs.absoluteInstallDirs-    (packageId pkg)-    uid-    (compilerInfo (compiler lbi))-    copydest-    (hostPlatform lbi)-    (installDirTemplates lbi)+absoluteComponentInstallDirs+  :: PackageDescription+  -> LocalBuildInfo+  -> UnitId+  -> CopyDest+  -> InstallDirs FilePath+absoluteComponentInstallDirs+  pkg+  (LocalBuildInfo{compiler = comp, hostPlatform = plat, installDirTemplates = installDirs})+  uid+  copydest =+    InstallDirs.absoluteInstallDirs+      (packageId pkg)+      uid+      (compilerInfo comp)+      copydest+      plat+      installDirs -absoluteInstallCommandDirs :: PackageDescription -> LocalBuildInfo-                           -> UnitId-                           -> CopyDest-                           -> InstallDirs FilePath+absoluteInstallCommandDirs+  :: PackageDescription+  -> LocalBuildInfo+  -> UnitId+  -> CopyDest+  -> InstallDirs FilePath absoluteInstallCommandDirs pkg lbi uid copydest =-  dirs {-    -- Handle files which are not-    -- per-component (data files and Haddock files.)-    datadir    = datadir    dirs',-    -- NB: The situation with Haddock is a bit delicate.  On the-    -- one hand, the easiest to understand Haddock documentation-    -- path is pkgname-0.1, which means it's per-package (not-    -- per-component).  But this means that it's impossible to-    -- install Haddock documentation for internal libraries.  We'll-    -- keep this constraint for now; this means you can't use-    -- Cabal to Haddock internal libraries.  This does not seem-    -- like a big problem.-    docdir     = docdir     dirs',-    htmldir    = htmldir    dirs',-    haddockdir = haddockdir dirs'+  dirs+    { -- Handle files which are not+      -- per-component (data files and Haddock files.)+      datadir = datadir dirs'+    , -- NB: The situation with Haddock is a bit delicate.  On the+      -- one hand, the easiest to understand Haddock documentation+      -- path is pkgname-0.1, which means it's per-package (not+      -- per-component).  But this means that it's impossible to+      -- install Haddock documentation for internal libraries.  We'll+      -- keep this constraint for now; this means you can't use+      -- Cabal to Haddock internal libraries.  This does not seem+      -- like a big problem.+      docdir = docdir dirs'+    , htmldir = htmldir dirs'+    , haddockdir = haddockdir dirs'     }   where-    dirs  = absoluteComponentInstallDirs pkg lbi uid copydest+    dirs = absoluteComponentInstallDirs pkg lbi uid copydest     -- Notice use of 'absoluteInstallDirs' (not the     -- per-component variant).  This means for non-library     -- packages we'll just pick a nondescriptive foo-0.1@@ -335,31 +438,46 @@ -- assuming that @$libname@ points to the public library (or some fake -- package identifier if there is no public library.)  IF AT ALL -- POSSIBLE, please use 'prefixRelativeComponentInstallDirs' instead.-prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo-                          -> InstallDirs (Maybe FilePath)+prefixRelativeInstallDirs+  :: PackageId+  -> LocalBuildInfo+  -> InstallDirs (Maybe FilePath) prefixRelativeInstallDirs pkg_descr lbi =-    prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId lbi)---- |See 'InstallDirs.prefixRelativeInstallDirs'-prefixRelativeComponentInstallDirs :: PackageId -> LocalBuildInfo-                                   -> UnitId-                                   -> InstallDirs (Maybe FilePath)-prefixRelativeComponentInstallDirs pkg_descr lbi uid =-  InstallDirs.prefixRelativeInstallDirs-    (packageId pkg_descr)-    uid-    (compilerInfo (compiler lbi))-    (hostPlatform lbi)-    (installDirTemplates lbi)+  prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId lbi) -substPathTemplate :: PackageId -> LocalBuildInfo-                  -> UnitId-                  -> PathTemplate -> FilePath-substPathTemplate pkgid lbi uid = fromPathTemplate-                                    . ( InstallDirs.substPathTemplate env )-    where env = initialPathTemplateEnv-                   pkgid-                   uid-                   (compilerInfo (compiler lbi))-                   (hostPlatform lbi)+-- | See 'InstallDirs.prefixRelativeInstallDirs'+prefixRelativeComponentInstallDirs+  :: PackageId+  -> LocalBuildInfo+  -> UnitId+  -> InstallDirs (Maybe FilePath)+prefixRelativeComponentInstallDirs+  pkg_descr+  (LocalBuildInfo{compiler = comp, hostPlatform = plat, installDirTemplates = installDirs})+  uid =+    InstallDirs.prefixRelativeInstallDirs+      (packageId pkg_descr)+      uid+      (compilerInfo comp)+      plat+      installDirs +substPathTemplate+  :: PackageId+  -> LocalBuildInfo+  -> UnitId+  -> PathTemplate+  -> FilePath+substPathTemplate+  pkgid+  (LocalBuildInfo{compiler = comp, hostPlatform = plat})+  uid =+    fromPathTemplate+      . (InstallDirs.substPathTemplate env)+    where+      env =+        initialPathTemplateEnv+          pkgid+          uid+          (compilerInfo comp)+          plat
+ src/Distribution/Simple/PackageDescription.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE DataKinds #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.PackageDescription+-- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This defines parsers for the @.cabal@ format+module Distribution.Simple.PackageDescription+  ( -- * Read and Parse files+    readGenericPackageDescription+  , readHookedBuildInfo++    -- * Utility Parsing function+  , parseString+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import qualified Data.ByteString as BS+import Data.List (groupBy)+import Distribution.Fields.ParseResult+import Distribution.PackageDescription+import Distribution.PackageDescription.Parsec+  ( parseGenericPackageDescription+  , parseHookedBuildInfo+  )+import Distribution.Parsec.Error (showPError)+import Distribution.Parsec.Warning+  ( PWarnType (PWTExperimental)+  , PWarning (..)+  , showPWarning+  )+import Distribution.Simple.Errors+import Distribution.Simple.Utils (dieWithException, equating, warn)+import Distribution.Utils.Path+import Distribution.Verbosity (Verbosity, normal)+import GHC.Stack+import System.Directory (doesFileExist)+import Text.Printf (printf)++readGenericPackageDescription+  :: HasCallStack+  => Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> SymbolicPath Pkg File+  -> IO GenericPackageDescription+readGenericPackageDescription =+  readAndParseFile parseGenericPackageDescription++readHookedBuildInfo+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ working directory+  -> SymbolicPath Pkg File+  -> IO HookedBuildInfo+readHookedBuildInfo =+  readAndParseFile parseHookedBuildInfo++-- | Helper combinator to do parsing plumbing for files.+--+-- Given a parser and a filename, return the parse of the file,+-- after checking if the file exists.+--+-- Argument order is chosen to encourage partial application.+readAndParseFile+  :: (BS.ByteString -> ParseResult a)+  -- ^ File contents to final value parser+  -> Verbosity+  -- ^ Verbosity level+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ Working directory+  -> SymbolicPath Pkg File+  -- ^ File to read+  -> IO a+readAndParseFile parser verbosity mbWorkDir fpath = do+  let ipath = interpretSymbolicPath mbWorkDir fpath+      upath = getSymbolicPath fpath+  exists <- doesFileExist ipath+  unless exists $+    dieWithException verbosity $+      ErrorParsingFileDoesntExist upath+  bs <- BS.readFile ipath+  parseString parser verbosity upath bs++parseString+  :: (BS.ByteString -> ParseResult a)+  -- ^ File contents to final value parser+  -> Verbosity+  -- ^ Verbosity level+  -> String+  -- ^ File name+  -> BS.ByteString+  -> IO a+parseString parser verbosity name bs = do+  let (warnings, result) = runParseResult (parser bs)+  traverse_ (warn verbosity . showPWarning name) (flattenDups verbosity warnings)+  case result of+    Right x -> return x+    Left (_, errors) -> do+      traverse_ (warn verbosity . showPError name) errors+      dieWithException verbosity $ FailedParsing name++-- | Collapse duplicate experimental feature warnings into single warning, with+-- a count of further sites+flattenDups :: Verbosity -> [PWarning] -> [PWarning]+flattenDups verbosity ws+  | verbosity <= normal = rest ++ experimentals+  | otherwise = ws -- show all instances+  where+    (exps, rest) = partition (\(PWarning w _ _) -> w == PWTExperimental) ws+    experimentals =+      concatMap flatCount+        . groupBy (equating warningStr)+        . sortBy (comparing warningStr)+        $ exps++    warningStr (PWarning _ _ w) = w++    -- flatten if we have 3 or more examples+    flatCount :: [PWarning] -> [PWarning]+    flatCount w@[] = w+    flatCount w@[_] = w+    flatCount w@[_, _] = w+    flatCount (PWarning t pos w : xs) =+      [ PWarning+          t+          pos+          (w <> printf " (and %d more occurrences)" (length xs))+      ]
src/Distribution/Simple/PackageIndex.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.PackageIndex -- Copyright   :  (c) David Himmelstrup 2005,@@ -43,80 +43,82 @@ -- 'Distribution.Client.PackageIndex', which indexes packages only by -- 'PackageName' (this makes it suitable for indexing source packages, -- for which we don't know 'UnitId's.)----module Distribution.Simple.PackageIndex (-  -- * Package index data type-  InstalledPackageIndex,-  PackageIndex,--  -- * Creating an index-  fromList,+module Distribution.Simple.PackageIndex+  ( -- * Package index data type+    InstalledPackageIndex+  , PackageIndex -  -- * Updates-  merge,+    -- * Creating an index+  , fromList -  insert,+    -- * Updates+  , merge+  , insert+  , deleteUnitId+  , deleteSourcePackageId+  , deletePackageName+  --  deleteDependency, -  deleteUnitId,-  deleteSourcePackageId,-  deletePackageName,---  deleteDependency,+    -- * Queries -  -- * Queries+    -- ** Precise lookups+  , lookupUnitId+  , lookupComponentId+  , lookupSourcePackageId+  , lookupPackageId+  , lookupPackageName+  , lookupInternalPackageName+  , lookupDependency+  , lookupInternalDependency -  -- ** Precise lookups-  lookupUnitId,-  lookupComponentId,-  lookupSourcePackageId,-  lookupPackageId,-  lookupPackageName,-  lookupDependency,-  lookupInternalDependency,+    -- ** Case-insensitive searches+  , searchByName+  , SearchResult (..)+  , searchByNameSubstring+  , searchWithPredicate -  -- ** Case-insensitive searches-  searchByName,-  SearchResult(..),-  searchByNameSubstring,-  searchWithPredicate,+    -- ** Bulk queries+  , allPackages+  , allPackagesByName+  , allPackagesBySourcePackageId+  , allPackagesBySourcePackageIdAndLibName -  -- ** Bulk queries-  allPackages,-  allPackagesByName,-  allPackagesBySourcePackageId,-  allPackagesBySourcePackageIdAndLibName,+    -- ** Special queries+  , brokenPackages+  , dependencyClosure+  , reverseDependencyClosure+  , topologicalOrder+  , reverseTopologicalOrder+  , dependencyInconsistencies+  , dependencyCycles+  , dependencyGraph+  , moduleNameIndex -  -- ** Special queries-  brokenPackages,-  dependencyClosure,-  reverseDependencyClosure,-  topologicalOrder,-  reverseTopologicalOrder,-  dependencyInconsistencies,-  dependencyCycles,-  dependencyGraph,-  moduleNameIndex+    -- ** Filters on lookup results+  , eligibleDependencies+  , matchingDependencies   ) where -import Prelude ()-import Distribution.Compat.Prelude hiding (lookup) import qualified Data.Map.Strict as Map+import Distribution.Compat.Prelude hiding (lookup)+import Prelude () -import Distribution.Package import Distribution.Backpack-import Distribution.ModuleName import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.Version+import Distribution.ModuleName+import Distribution.Package import Distribution.Simple.Utils import Distribution.Types.LibraryName+import Distribution.Version  import Control.Exception (assert)+import Control.Monad import Data.Array ((!)) import qualified Data.Array as Array import qualified Data.Graph as Graph-import Data.List as List ( groupBy,  deleteBy, deleteFirstsBy )+import Data.List as List (deleteBy, deleteFirstsBy, groupBy) import qualified Data.List.NonEmpty as NE-import qualified Data.Tree  as Tree-import Control.Monad+import qualified Data.Tree as Tree import Distribution.Compat.Stack  import qualified Prelude (foldr1)@@ -126,27 +128,25 @@ -- -- Packages are uniquely identified in by their 'UnitId', they can -- also be efficiently looked up by package name or by name and version.----data PackageIndex a = PackageIndex {-  -- The primary index. Each InstalledPackageInfo record is uniquely identified-  -- by its UnitId.-  ---  unitIdIndex :: !(Map UnitId a),--  -- This auxiliary index maps package names (case-sensitively) to all the-  -- versions and instances of that package. This allows us to find all-  -- versions satisfying a dependency.-  ---  -- It is a three-level index. The first level is the package name,-  -- the second is the package version and the final level is instances-  -- of the same package version. These are unique by UnitId-  -- and are kept in preference order.-  ---  -- FIXME: Clarify what "preference order" means. Check that this invariant is-  -- preserved. See #1463 for discussion.-  packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a]))--  } deriving (Eq, Generic, Show, Read, Typeable)+data PackageIndex a = PackageIndex+  { -- The primary index. Each InstalledPackageInfo record is uniquely identified+    -- by its UnitId.+    --+    unitIdIndex :: !(Map UnitId a)+  , -- This auxiliary index maps package names (case-sensitively) to all the+    -- versions and instances of that package. This allows us to find all+    -- versions satisfying a dependency.+    --+    -- It is a three-level index. The first level is the package name,+    -- the second is the package version and the final level is instances+    -- of the same package version. These are unique by UnitId+    -- and are kept in preference order.+    --+    -- FIXME: Clarify what "preference order" means. Check that this invariant is+    -- preserved. See #1463 for discussion.+    packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a]))+  }+  deriving (Eq, Generic, Show, Read)  instance Binary a => Binary (PackageIndex a) instance Structured a => Structured (PackageIndex a)@@ -156,9 +156,10 @@ type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo  instance Monoid (PackageIndex IPI.InstalledPackageInfo) where-  mempty  = PackageIndex Map.empty Map.empty+  mempty = PackageIndex Map.empty Map.empty   mappend = (<>)-  --save one mappend with empty in the common case:++  -- save one mappend with empty in the common case:   mconcat [] = mempty   mconcat xs = Prelude.foldr1 mappend xs @@ -170,69 +171,84 @@ invariant (PackageIndex pids pnames) =   -- trace (show pids' ++ "\n" ++ show pnames') $   pids' == pnames'- where-  pids' = map installedUnitId (Map.elems pids)-  pnames' = sort-     [ assert pinstOk (installedUnitId pinst)-     | ((pname, plib), pvers)  <- Map.toList pnames-     , let pversOk = not (Map.null pvers)-     , (pver,  pinsts) <- assert pversOk $ Map.toList pvers-     , let pinsts'  = sortBy (comparing installedUnitId) pinsts-           pinstsOk = all (\g -> length g == 1)-                          (groupBy (equating installedUnitId) pinsts')-     , pinst           <- assert pinstsOk $ pinsts'-     , let pinstOk = packageName    pinst == pname+  where+    pids' = map installedUnitId (Map.elems pids)+    pnames' =+      sort+        [ assert pinstOk (installedUnitId pinst)+        | ((pname, plib), pvers) <- Map.toList pnames+        , let pversOk = not (Map.null pvers)+        , (pver, pinsts) <- assert pversOk $ Map.toList pvers+        , let pinsts' = sortBy (comparing installedUnitId) pinsts+              pinstsOk =+                all+                  (\g -> length g == 1)+                  (groupBy (equating installedUnitId) pinsts')+        , pinst <- assert pinstsOk $ pinsts'+        , let pinstOk =+                packageName pinst == pname                   && packageVersion pinst == pver-                  && IPI.sourceLibName  pinst == plib-     ]-  -- If you see this invariant failing (ie the assert in mkPackageIndex below)-  -- then one thing to check is if it is happening in fromList. Check if the-  -- second list above (the sort [...] bit) is ending up with duplicates. This-  -- has been observed in practice once due to a messed up ghc-pkg db. How/why-  -- it became messed up was not discovered.+                  && IPI.sourceLibName pinst == plib+        ] +-- If you see this invariant failing (ie the assert in mkPackageIndex below)+-- then one thing to check is if it is happening in fromList. Check if the+-- second list above (the sort [...] bit) is ending up with duplicates. This+-- has been observed in practice once due to a messed up ghc-pkg db. How/why+-- it became messed up was not discovered.  --+ -- * Internal helpers+ -- -mkPackageIndex :: WithCallStack (Map UnitId IPI.InstalledPackageInfo-               -> Map (PackageName, LibraryName)-                      (Map Version [IPI.InstalledPackageInfo])-               -> InstalledPackageIndex)+mkPackageIndex+  :: WithCallStack+      ( Map UnitId IPI.InstalledPackageInfo+        -> Map+            (PackageName, LibraryName)+            (Map Version [IPI.InstalledPackageInfo])+        -> InstalledPackageIndex+      ) mkPackageIndex pids pnames = assert (invariant index) index-  where index = PackageIndex pids pnames-+  where+    index = PackageIndex pids pnames  --+ -- * Construction+ --  -- | Build an index out of a bunch of packages. -- -- If there are duplicates by 'UnitId' then later ones mask earlier -- ones.--- fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames)   where-    pids      = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ]-    pnames    =+    pids = Map.fromList [(installedUnitId pkg, pkg) | pkg <- pkgs]+    pnames =       Map.fromList         [ (liftM2 (,) packageName IPI.sourceLibName (NE.head pkgsN), pvers)-        | pkgsN <- NE.groupBy (equating  (liftM2 (,) packageName IPI.sourceLibName))-                 . sortBy  (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion))-                 $ pkgs+        | pkgsN <-+            NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName))+              . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion))+              $ pkgs         , let pvers =                 Map.fromList-                [ (packageVersion (NE.head pkgsNV),-                   NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV))-                | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN-                ]+                  [ ( packageVersion (NE.head pkgsNV)+                    , NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV)+                    )+                  | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN+                  ]         ]  --+ -- * Updates+ --  -- | Merge two indexes.@@ -244,101 +260,110 @@ -- \"preferred\" over those from the first. Being preferred means they are top -- result when we do a lookup by source 'PackageId'. This is the mechanism we -- use to prefer user packages over global packages.----merge :: InstalledPackageIndex -> InstalledPackageIndex-      -> InstalledPackageIndex+merge+  :: InstalledPackageIndex+  -> InstalledPackageIndex+  -> InstalledPackageIndex merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) =-  mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2)-                 (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2)+  mkPackageIndex+    (Map.unionWith (\_ y -> y) pids1 pids2)+    (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2)   where     -- Packages in the second list mask those in the first, however preferred     -- packages go first in the list.     mergeBuckets xs ys = ys ++ (xs \\ ys)     (\\) = deleteFirstsBy (equating installedUnitId) - -- | Inserts a single package into the index. -- -- This is equivalent to (but slightly quicker than) using 'mappend' or -- 'merge' with a singleton index.--- insert :: IPI.InstalledPackageInfo -> InstalledPackageIndex -> InstalledPackageIndex insert pkg (PackageIndex pids pnames) =-    mkPackageIndex pids' pnames'-+  mkPackageIndex pids' pnames'   where-    pids'   = Map.insert (installedUnitId pkg) pkg pids+    pids' = Map.insert (installedUnitId pkg) pkg pids     pnames' = insertPackageName pnames     insertPackageName =-      Map.insertWith (\_ -> insertPackageVersion)-                     (packageName pkg, IPI.sourceLibName pkg)-                     (Map.singleton (packageVersion pkg) [pkg])+      Map.insertWith+        (\_ -> insertPackageVersion)+        (packageName pkg, IPI.sourceLibName pkg)+        (Map.singleton (packageVersion pkg) [pkg])      insertPackageVersion =-      Map.insertWith (\_ -> insertPackageInstance)-                     (packageVersion pkg) [pkg]+      Map.insertWith+        (\_ -> insertPackageInstance)+        (packageVersion pkg)+        [pkg]      insertPackageInstance pkgs =       pkg : deleteBy (equating installedUnitId) pkg pkgs - -- | Removes a single installed package from the index.----deleteUnitId :: UnitId -> InstalledPackageIndex-             -> InstalledPackageIndex+deleteUnitId+  :: UnitId+  -> InstalledPackageIndex+  -> InstalledPackageIndex deleteUnitId ipkgid original@(PackageIndex pids pnames) =   case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of-    (Nothing,     _)     -> original-    (Just spkgid, pids') -> mkPackageIndex pids'-                                          (deletePkgName spkgid pnames)-+    (Nothing, _) -> original+    (Just spkgid, pids') ->+      mkPackageIndex+        pids'+        (deletePkgName spkgid pnames)   where     deletePkgName spkgid =       Map.update (deletePkgVersion spkgid) (packageName spkgid, IPI.sourceLibName spkgid)      deletePkgVersion spkgid =-        (\m -> if Map.null m then Nothing else Just m)-      . Map.update deletePkgInstance (packageVersion spkgid)+      (\m -> if Map.null m then Nothing else Just m)+        . Map.update deletePkgInstance (packageVersion spkgid)      deletePkgInstance =-        (\xs -> if null xs then Nothing else Just xs)-      . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined+      (\xs -> if null xs then Nothing else Just xs)+        . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined  -- | Removes all packages with this source 'PackageId' from the index.----deleteSourcePackageId :: PackageId -> InstalledPackageIndex-                      -> InstalledPackageIndex+deleteSourcePackageId+  :: PackageId+  -> InstalledPackageIndex+  -> InstalledPackageIndex deleteSourcePackageId pkgid original@(PackageIndex pids pnames) =   -- NB: Doesn't delete internal packages   case Map.lookup (packageName pkgid, LMainLibName) pnames of-    Nothing     -> original-    Just pvers  -> case Map.lookup (packageVersion pkgid) pvers of-      Nothing   -> original-      Just pkgs -> mkPackageIndex-                     (foldl' (flip (Map.delete . installedUnitId)) pids pkgs)-                     (deletePkgName pnames)+    Nothing -> original+    Just pvers -> case Map.lookup (packageVersion pkgid) pvers of+      Nothing -> original+      Just pkgs ->+        mkPackageIndex+          (foldl' (flip (Map.delete . installedUnitId)) pids pkgs)+          (deletePkgName pnames)   where     deletePkgName =       Map.update deletePkgVersion (packageName pkgid, LMainLibName)      deletePkgVersion =-        (\m -> if Map.null m then Nothing else Just m)-      . Map.delete (packageVersion pkgid)-+      (\m -> if Map.null m then Nothing else Just m)+        . Map.delete (packageVersion pkgid)  -- | Removes all packages with this (case-sensitive) name from the index. -- -- NB: Does NOT delete internal libraries from this package.----deletePackageName :: PackageName -> InstalledPackageIndex-                  -> InstalledPackageIndex+deletePackageName+  :: PackageName+  -> InstalledPackageIndex+  -> InstalledPackageIndex deletePackageName name original@(PackageIndex pids pnames) =   case Map.lookup (name, LMainLibName) pnames of-    Nothing     -> original-    Just pvers  -> mkPackageIndex-                     (foldl' (flip (Map.delete . installedUnitId)) pids-                             (concat (Map.elems pvers)))-                     (Map.delete (name, LMainLibName) pnames)+    Nothing -> original+    Just pvers ->+      mkPackageIndex+        ( foldl'+            (flip (Map.delete . installedUnitId))+            pids+            (concat (Map.elems pvers))+        )+        (Map.delete (name, LMainLibName) pnames)  {- -- | Removes all packages satisfying this dependency from the index.@@ -349,11 +374,12 @@ -}  --+ -- * Bulk queries+ --  -- | Get all the packages from the index.--- allPackages :: PackageIndex a -> [a] allPackages = Map.elems . unitIdIndex @@ -362,91 +388,110 @@ -- They are grouped by package name (case-sensitively). -- -- (Doesn't include private libraries.)--- allPackagesByName :: PackageIndex a -> [(PackageName, [a])] allPackagesByName index =   [ (pkgname, concat (Map.elems pvers))-  | ((pkgname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) ]+  | ((pkgname, LMainLibName), pvers) <- Map.toList (packageIdIndex index)+  ]  -- | Get all the packages from the index. -- -- They are grouped by source package id (package name and version). -- -- (Doesn't include private libraries)----allPackagesBySourcePackageId :: HasUnitId a => PackageIndex a-                             -> [(PackageId, [a])]+allPackagesBySourcePackageId+  :: HasUnitId a+  => PackageIndex a+  -> [(PackageId, [a])] allPackagesBySourcePackageId index =   [ (packageId ipkg, ipkgs)   | ((_, LMainLibName), pvers) <- Map.toList (packageIdIndex index)-  , ipkgs@(ipkg:_) <- Map.elems pvers ]+  , ipkgs@(ipkg : _) <- Map.elems pvers+  ]  -- | Get all the packages from the index. -- -- They are grouped by source package id and library name. -- -- This DOES include internal libraries.-allPackagesBySourcePackageIdAndLibName :: HasUnitId a => PackageIndex a-                             -> [((PackageId, LibraryName), [a])]+allPackagesBySourcePackageIdAndLibName+  :: HasUnitId a+  => PackageIndex a+  -> [((PackageId, LibraryName), [a])] allPackagesBySourcePackageIdAndLibName index =   [ ((packageId ipkg, ln), ipkgs)   | ((_, ln), pvers) <- Map.toList (packageIdIndex index)-  , ipkgs@(ipkg:_) <- Map.elems pvers ]+  , ipkgs@(ipkg : _) <- Map.elems pvers+  ]  --+ -- * Lookups+ --  -- | Does a lookup by unit identifier. -- -- Since multiple package DBs mask each other by 'UnitId', -- then we get back at most one package.----lookupUnitId :: PackageIndex a -> UnitId-             -> Maybe a+lookupUnitId+  :: PackageIndex a+  -> UnitId+  -> Maybe a lookupUnitId index uid = Map.lookup uid (unitIdIndex index)  -- | Does a lookup by component identifier.  In the absence -- of Backpack, this is just a 'lookupUnitId'.----lookupComponentId :: PackageIndex a -> ComponentId-                  -> Maybe a+lookupComponentId+  :: PackageIndex a+  -> ComponentId+  -> Maybe a lookupComponentId index cid =-    Map.lookup (newSimpleUnitId cid) (unitIdIndex index)+  Map.lookup (newSimpleUnitId cid) (unitIdIndex index)  -- | Does a lookup by source package id (name & version). -- -- There can be multiple installed packages with the same source 'PackageId' -- but different 'UnitId'. They are returned in order of -- preference, with the most preferred first.--- lookupSourcePackageId :: PackageIndex a -> PackageId -> [a] lookupSourcePackageId index pkgid =   -- Do not lookup internal libraries   case Map.lookup (packageName pkgid, LMainLibName) (packageIdIndex index) of-    Nothing     -> []-    Just pvers  -> case Map.lookup (packageVersion pkgid) pvers of-      Nothing   -> []+    Nothing -> []+    Just pvers -> case Map.lookup (packageVersion pkgid) pvers of+      Nothing -> []       Just pkgs -> pkgs -- in preference order  -- | Convenient alias of 'lookupSourcePackageId', but assuming only -- one package per package ID. lookupPackageId :: PackageIndex a -> PackageId -> Maybe a-lookupPackageId index pkgid = case lookupSourcePackageId index pkgid  of-    []    -> Nothing-    [pkg] -> Just pkg-    _     -> error "Distribution.Simple.PackageIndex: multiple matches found"+lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of+  [] -> Nothing+  [pkg] -> Just pkg+  _ -> error "Distribution.Simple.PackageIndex: multiple matches found"  -- | Does a lookup by source package name.----lookupPackageName :: PackageIndex a -> PackageName-                  -> [(Version, [a])]+lookupPackageName+  :: PackageIndex a+  -> PackageName+  -> [(Version, [a])] lookupPackageName index name =   -- Do not match internal libraries-  case Map.lookup (name, LMainLibName) (packageIdIndex index) of-    Nothing     -> []-    Just pvers  -> Map.toList pvers+  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 =+  case Map.lookup (name, library) (packageIdIndex index) of+    Nothing -> []+    Just pvers -> Map.toList pvers  -- | Does a lookup by source package name and a range of versions. --@@ -457,12 +502,14 @@ -- function on those; use 'lookupInternalDependency' instead. -- -- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty.----lookupDependency :: InstalledPackageIndex -> PackageName -> VersionRange-                 -> [(Version, [IPI.InstalledPackageInfo])]+lookupDependency+  :: InstalledPackageIndex+  -> PackageName+  -> VersionRange+  -> [(Version, [IPI.InstalledPackageInfo])] lookupDependency index pn vr =-    -- Yes, a little bit of a misnomer here!-    lookupInternalDependency index pn vr LMainLibName+  -- Yes, a little bit of a misnomer here!+  lookupInternalDependency index pn vr LMainLibName  -- | Does a lookup by source package name and a range of versions. --@@ -470,30 +517,57 @@ -- satisfying the version range constraint. -- -- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty.----lookupInternalDependency :: InstalledPackageIndex -> PackageName -> VersionRange-                 -> LibraryName-                 -> [(Version, [IPI.InstalledPackageInfo])]+lookupInternalDependency+  :: InstalledPackageIndex+  -> PackageName+  -> VersionRange+  -> LibraryName+  -> [(Version, [IPI.InstalledPackageInfo])] lookupInternalDependency index name versionRange libn =-  case Map.lookup (name, libn) (packageIdIndex index) of-    Nothing    -> []-    Just pvers -> [ (ver, pkgs')-                  | (ver, pkgs) <- Map.toList pvers-                  , ver `withinRange` versionRange-                  , let pkgs' = filter eligible pkgs-                  -- Enforce the invariant-                  , not (null pkgs')-                  ]- where-  -- When we select for dependencies, we ONLY want to pick up indefinite-  -- packages, or packages with no instantiations.  We'll do mix-in-  -- linking to improve any such package into an instantiated one-  -- later.-  eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg)+  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+    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+ --  -- | Does a case-insensitive search by package name.@@ -507,42 +581,45 @@ -- have an ambiguous result, and we get back all the versions of all the -- packages. The list of ambiguous results is split by exact package name. So -- it is a non-empty list of non-empty lists.--- searchByName :: PackageIndex a -> String -> SearchResult [a] searchByName index name =   -- Don't match internal packages-  case [ pkgs | pkgs@((pname, LMainLibName),_) <- Map.toList (packageIdIndex index)-              , lowercase (unPackageName pname) == lname ] of-    []               -> None-    [(_,pvers)]      -> Unambiguous (concat (Map.elems pvers))-    pkgss            -> case find ((mkPackageName name ==) . fst . fst) pkgss of-      Just (_,pvers) -> Unambiguous (concat (Map.elems pvers))-      Nothing        -> Ambiguous (map (concat . Map.elems . snd) pkgss)-  where lname = lowercase name+  case [ pkgs | pkgs@((pname, LMainLibName), _) <- Map.toList (packageIdIndex index), lowercase (unPackageName pname) == lname+       ] of+    [] -> None+    [(_, pvers)] -> Unambiguous (concat (Map.elems pvers))+    pkgss -> case find ((mkPackageName name ==) . fst . fst) pkgss of+      Just (_, pvers) -> Unambiguous (concat (Map.elems pvers))+      Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss)+  where+    lname = lowercase name  data SearchResult a = None | Unambiguous a | Ambiguous [a]  -- | Does a case-insensitive substring search by package name. -- -- That is, all packages that contain the given string in their name.--- searchByNameSubstring :: PackageIndex a -> String -> [a] searchByNameSubstring index searchterm =   searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n)-  where lsearchterm = lowercase searchterm+  where+    lsearchterm = lowercase searchterm  -- | @since 3.4.0.0 searchWithPredicate :: PackageIndex a -> (String -> Bool) -> [a] searchWithPredicate index predicate =   [ pkg-  -- Don't match internal packages-  | ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index)+  | -- Don't match internal packages+  ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index)   , predicate (unPackageName pname)   , pkgs <- Map.elems pvers-  , pkg <- pkgs ]+  , pkg <- pkgs+  ]  --+ -- * Special queries+ --  -- None of the stuff below depends on the internal representation of the index.@@ -554,27 +631,30 @@ -- This actually computes the strongly connected components. So it gives us a -- list of groups of packages where within each group they all depend on each -- other, directly or indirectly.--- dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]] dependencyCycles index =-  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]+  [vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList]   where-    adjacencyList = [ (pkg, installedUnitId pkg, installedDepends pkg)-                    | pkg <- allPackages index ]-+    adjacencyList =+      [ (pkg, installedUnitId pkg, installedDepends pkg)+      | pkg <- allPackages index+      ]  -- | All packages that have immediate dependencies that are not in the index. -- -- Returns such packages along with the dependencies that they're missing.----brokenPackages :: PackageInstalled a => PackageIndex a-               -> [(a, [UnitId])]+brokenPackages+  :: PackageInstalled a+  => PackageIndex a+  -> [(a, [UnitId])] brokenPackages index =   [ (pkg, missing)-  | pkg  <- allPackages index-  , let missing = [ pkg' | pkg' <- installedDepends pkg-                         , isNothing (lookupUnitId index pkg') ]-  , not (null missing) ]+  | pkg <- allPackages index+  , let missing =+          [ pkg' | pkg' <- installedDepends pkg, isNothing (lookupUnitId index pkg')+          ]+  , not (null missing)+  ]  -- | Tries to take the transitive closure of the package dependencies. --@@ -583,78 +663,89 @@ -- -- * Note that if the result is @Right []@ it is because at least one of -- the original given 'PackageId's do not occur in the index.----dependencyClosure :: InstalledPackageIndex-                  -> [UnitId]-                  -> Either (InstalledPackageIndex)-                            [(IPI.InstalledPackageInfo, [UnitId])]+dependencyClosure+  :: InstalledPackageIndex+  -> [UnitId]+  -> Either+      (InstalledPackageIndex)+      [(IPI.InstalledPackageInfo, [UnitId])] dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of   (completed, []) -> Left completed-  (completed, _)  -> Right (brokenPackages completed)- where-    closure completed failed []             = (completed, failed)-    closure completed failed (pkgid:pkgids) = case lookupUnitId index pkgid of-      Nothing   -> closure completed (pkgid:failed) pkgids-      Just pkg  -> case lookupUnitId completed (installedUnitId pkg) of-        Just _  -> closure completed  failed pkgids+  (completed, _) -> Right (brokenPackages completed)+  where+    closure completed failed [] = (completed, failed)+    closure completed failed (pkgid : pkgids) = case lookupUnitId index pkgid of+      Nothing -> closure completed (pkgid : failed) pkgids+      Just pkg -> case lookupUnitId completed (installedUnitId pkg) of+        Just _ -> closure completed failed pkgids         Nothing -> closure completed' failed pkgids'-          where completed' = insert pkg completed-                pkgids'    = installedDepends pkg ++ pkgids+          where+            completed' = insert pkg completed+            pkgids' = installedDepends pkg ++ pkgids  -- | Takes the transitive closure of the packages reverse dependencies. -- -- * The given 'PackageId's must be in the index.----reverseDependencyClosure :: PackageInstalled a => PackageIndex a-                         -> [UnitId]-                         -> [a]+reverseDependencyClosure+  :: PackageInstalled a+  => PackageIndex a+  -> [UnitId]+  -> [a] reverseDependencyClosure index =-    map vertexToPkg-  . concatMap Tree.flatten-  . Graph.dfs reverseDepGraph-  . map (fromMaybe noSuchPkgId . pkgIdToVertex)-+  map vertexToPkg+    . concatMap Tree.flatten+    . Graph.dfs reverseDepGraph+    . map (fromMaybe noSuchPkgId . pkgIdToVertex)   where     (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index     reverseDepGraph = Graph.transposeG depGraph     noSuchPkgId = error "reverseDependencyClosure: package is not in the graph"  topologicalOrder :: PackageInstalled a => PackageIndex a -> [a]-topologicalOrder index = map toPkgId-                       . Graph.topSort-                       $ graph-  where (graph, toPkgId, _) = dependencyGraph index+topologicalOrder index =+  map toPkgId+    . Graph.topSort+    $ graph+  where+    (graph, toPkgId, _) = dependencyGraph index  reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a]-reverseTopologicalOrder index = map toPkgId-                              . Graph.topSort-                              . Graph.transposeG-                              $ graph-  where (graph, toPkgId, _) = dependencyGraph index+reverseTopologicalOrder index =+  map toPkgId+    . Graph.topSort+    . Graph.transposeG+    $ graph+  where+    (graph, toPkgId, _) = dependencyGraph index  -- | Builds a graph of the package dependencies. -- -- Dependencies on other packages that are not in the index are discarded. -- You can check if there are any such dependencies with 'brokenPackages'.----dependencyGraph :: PackageInstalled a => PackageIndex a-                -> (Graph.Graph,-                    Graph.Vertex -> a,-                    UnitId -> Maybe Graph.Vertex)+dependencyGraph+  :: PackageInstalled a+  => PackageIndex a+  -> ( Graph.Graph+     , Graph.Vertex -> a+     , UnitId -> Maybe Graph.Vertex+     ) dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex)   where-    graph = Array.listArray bounds-              [ [ v | Just v <- map id_to_vertex (installedDepends pkg) ]-              | pkg <- pkgs ]+    graph =+      Array.listArray+        bounds+        [ [v | Just v <- map id_to_vertex (installedDepends pkg)]+        | pkg <- pkgs+        ] -    pkgs             = sortBy (comparing packageId) (allPackages index)-    vertices         = zip (map installedUnitId pkgs) [0..]-    vertex_map       = Map.fromList vertices+    pkgs = sortBy (comparing packageId) (allPackages index)+    vertices = zip (map installedUnitId pkgs) [0 ..]+    vertex_map = Map.fromList vertices     id_to_vertex pid = Map.lookup pid vertex_map      vertex_to_pkg vertex = pkgTable ! vertex -    pkgTable   = Array.listArray bounds pkgs+    pkgTable = Array.listArray bounds pkgs     topBound = length pkgs - 1     bounds = (0, topBound) @@ -671,29 +762,36 @@ -- Each element in the result is a package name along with the packages that -- depend on it and the versions they require. These are guaranteed to be -- distinct.----dependencyInconsistencies :: InstalledPackageIndex-                             -- At DepUniqueKey...-                          -> [(DepUniqueKey,-                               -- There were multiple packages (BAD!)-                               [(UnitId,-                                 -- And here are the packages which-                                 -- immediately depended on it-                                 [IPI.InstalledPackageInfo])])]+dependencyInconsistencies+  :: InstalledPackageIndex+  -- At DepUniqueKey...+  -> [ ( DepUniqueKey+       , -- There were multiple packages (BAD!)+         [ ( UnitId+           , -- And here are the packages which+             -- immediately depended on it+             [IPI.InstalledPackageInfo]+           )+         ]+       )+     ] dependencyInconsistencies index = do-    (dep_key, insts_map) <- Map.toList inverseIndex-    let insts = Map.toList insts_map-    guard (length insts >= 2)-    return (dep_key, insts)+  (dep_key, insts_map) <- Map.toList inverseIndex+  let insts = Map.toList insts_map+  guard (length insts >= 2)+  return (dep_key, insts)   where     inverseIndex :: Map DepUniqueKey (Map UnitId [IPI.InstalledPackageInfo])     inverseIndex = Map.fromListWith (Map.unionWith (++)) $ do-        pkg <- allPackages index-        dep_ipid <- installedDepends pkg-        Just dep <- [lookupUnitId index dep_ipid]-        let dep_key = (packageName dep, IPI.sourceLibName dep,-                       Map.fromList (IPI.instantiatedWith dep))-        return (dep_key, Map.singleton dep_ipid [pkg])+      pkg <- allPackages index+      dep_ipid <- installedDepends pkg+      Just dep <- [lookupUnitId index dep_ipid]+      let dep_key =+            ( packageName dep+            , IPI.sourceLibName dep+            , Map.fromList (IPI.instantiatedWith dep)+            )+      return (dep_key, Map.singleton dep_ipid [pkg])  -- | A rough approximation of GHC's module finder, takes a -- 'InstalledPackageIndex' and turns it into a map from module names to their@@ -705,12 +803,14 @@     pkg <- allPackages index     IPI.ExposedModule m reexport <- IPI.exposedModules pkg     case reexport of-        Nothing -> return (m, [pkg])-        Just (OpenModuleVar _) -> []-        Just (OpenModule _ m') | m == m'   -> []-                                | otherwise -> return (m', [pkg])-        -- The heuristic is this: we want to prefer the original package-        -- which originally exported a module.  However, if a reexport-        -- also *renamed* the module (m /= m'), then we have to use the-        -- downstream package, since the upstream package has the wrong-        -- module name!+      Nothing -> return (m, [pkg])+      Just (OpenModuleVar _) -> []+      Just (OpenModule _ m')+        | m == m' -> []+        | otherwise -> return (m', [pkg])++-- The heuristic is this: we want to prefer the original package+-- which originally exported a module.  However, if a reexport+-- also *renamed* the module (m /= m'), then we have to use the+-- downstream package, since the upstream package has the wrong+-- module name!
src/Distribution/Simple/PreProcess.hs view
@@ -1,779 +1,932 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.PreProcess--- Copyright   :  (c) 2003-2005, Isaac Jones, Malcolm Wallace--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This defines a 'PreProcessor' abstraction which represents a pre-processor--- that can transform one kind of file into another. There is also a--- 'PPSuffixHandler' which is a combination of a file extension and a function--- for configuring a 'PreProcessor'. It defines a bunch of known built-in--- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and--- lists them in 'knownSuffixHandlers'. On top of this it provides a function--- for actually preprocessing some sources given a bunch of known suffix--- handlers. This module is not as good as it could be, it could really do with--- a rewrite to address some of the problems we have with pre-processors.--module Distribution.Simple.PreProcess (preprocessComponent, preprocessExtras,-                                knownSuffixHandlers, ppSuffixes,-                                PPSuffixHandler, PreProcessor(..),-                                mkSimplePreProcessor, runSimplePreProcessor,-                                ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs,-                                ppHappy, ppAlex, ppUnlit, platformDefines-                               )-    where--import Prelude ()-import Distribution.Compat.Prelude-import Distribution.Compat.Stack--import Distribution.Simple.PreProcess.Unlit-import Distribution.Backpack.DescribeUnitId-import Distribution.Package-import qualified Distribution.ModuleName as ModuleName-import Distribution.ModuleName (ModuleName)-import Distribution.PackageDescription as PD-import qualified Distribution.InstalledPackageInfo as Installed-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.CCompiler-import Distribution.Simple.Compiler-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.BuildPaths-import Distribution.Simple.Utils-import Distribution.Simple.Program-import Distribution.Simple.Program.ResponseFile-import Distribution.Simple.Test.LibV09-import Distribution.System-import Distribution.Pretty-import Distribution.Version-import Distribution.Verbosity-import Distribution.Utils.Path--import System.Directory (doesFileExist)-import System.Info (os, arch)-import System.FilePath (splitExtension, dropExtensions, (</>), (<.>),-                        takeDirectory, normalise, replaceExtension,-                        takeExtensions)---- |The interface to a preprocessor, which may be implemented using an--- external program, but need not be.  The arguments are the name of--- the input file, the name of the output file and a verbosity level.--- Here is a simple example that merely prepends a comment to the given--- source file:------ > ppTestHandler :: PreProcessor--- > ppTestHandler =--- >   PreProcessor {--- >     platformIndependent = True,--- >     runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->--- >       do info verbosity (inFile++" has been preprocessed to "++outFile)--- >          stuff <- readFile inFile--- >          writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff)--- >          return ExitSuccess------ We split the input and output file names into a base directory and the--- rest of the file name. The input base dir is the path in the list of search--- dirs that this file was found in. The output base dir is the build dir where--- all the generated source files are put.------ The reason for splitting it up this way is that some pre-processors don't--- simply generate one output .hs file from one input file but have--- dependencies on other generated files (notably c2hs, where building one--- .hs file may require reading other .chi files, and then compiling the .hs--- file may require reading a generated .h file). In these cases the generated--- files need to embed relative path names to each other (eg the generated .hs--- file mentions the .h file in the FFI imports). This path must be relative to--- the base directory where the generated files are located, it cannot be--- relative to the top level of the build tree because the compilers do not--- look for .h files relative to there, ie we do not use \"-I .\", instead we--- use \"-I dist\/build\" (or whatever dist dir has been set by the user)------ Most pre-processors do not care of course, so mkSimplePreProcessor and--- runSimplePreProcessor functions handle the simple case.----data PreProcessor = PreProcessor {--  -- Is the output of the pre-processor platform independent? eg happy output-  -- is portable haskell but c2hs's output is platform dependent.-  -- This matters since only platform independent generated code can be-  -- included into a source tarball.-  platformIndependent :: Bool,--  -- TODO: deal with pre-processors that have implementation dependent output-  --       eg alex and happy have --ghc flags. However we can't really include-  --       ghc-specific code into supposedly portable source tarballs.--  runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir-                  -> (FilePath, FilePath) -- Output file name, relative to an output base dir-                  -> Verbosity -- verbosity-                  -> IO ()     -- Should exit if the preprocessor fails-  }---- | Function to determine paths to possible extra C sources for a--- preprocessor: just takes the path to the build directory and uses--- this to search for C sources with names that match the--- preprocessor's output name format.-type PreProcessorExtras = FilePath -> IO [FilePath]---mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ())-                      -> (FilePath, FilePath)-                      -> (FilePath, FilePath) -> Verbosity -> IO ()-mkSimplePreProcessor simplePP-  (inBaseDir, inRelativeFile)-  (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity-  where inFile  = normalise (inBaseDir  </> inRelativeFile)-        outFile = normalise (outBaseDir </> outRelativeFile)--runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity-                      -> IO ()-runSimplePreProcessor pp inFile outFile verbosity =-  runPreProcessor pp (".", inFile) (".", outFile) verbosity---- |A preprocessor for turning non-Haskell files with the given extension--- into plain Haskell source files.-type PPSuffixHandler-    = (String, BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor)---- | Apply preprocessors to the sources from 'hsSourceDirs' for a given--- component (lib, exe, or test suite).------ XXX: This is terrible-preprocessComponent :: PackageDescription-                    -> Component-                    -> LocalBuildInfo-                    -> ComponentLocalBuildInfo-                    -> Bool-                    -> Verbosity-                    -> [PPSuffixHandler]-                    -> IO ()-preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = do- -- NB: never report instantiation here; we'll report it properly when- -- building.- setupMessage' verbosity "Preprocessing" (packageId pd)-    (componentLocalName clbi) (Nothing :: Maybe [(ModuleName, Module)])- case comp of-  (CLib lib@Library{ libBuildInfo = bi }) -> do-    let dirs = map getSymbolicPath (hsSourceDirs bi) ++-             [ autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi]-    for_ (map ModuleName.toFilePath $ allLibModules lib clbi) $-      pre dirs (componentBuildDir lbi clbi) (localHandlers bi)-  (CFLib flib@ForeignLib { foreignLibBuildInfo = bi, foreignLibName = nm }) -> do-    let nm' = unUnqualComponentName nm-    let flibDir = buildDir lbi </> nm' </> nm' ++ "-tmp"-        dirs    = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi-                                     ,autogenPackageModulesDir lbi]-    for_ (map ModuleName.toFilePath $ foreignLibModules flib) $-      pre dirs flibDir (localHandlers bi)-  (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do-    let nm' = unUnqualComponentName nm-    let exeDir = buildDir lbi </> nm' </> nm' ++ "-tmp"-        dirs   = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi-                                    ,autogenPackageModulesDir lbi]-    for_ (map ModuleName.toFilePath $ otherModules bi) $-      pre dirs exeDir (localHandlers bi)-    pre (map getSymbolicPath (hsSourceDirs bi)) exeDir (localHandlers bi) $-      dropExtensions (modulePath exe)-  CTest test@TestSuite{ testName = nm } -> do-    let nm' = unUnqualComponentName nm-    case testInterface test of-      TestSuiteExeV10 _ f ->-          preProcessTest test f $ buildDir lbi </> nm' </> nm' ++ "-tmp"-      TestSuiteLibV09 _ _ -> do-          let testDir = buildDir lbi </> stubName test-                  </> stubName test ++ "-tmp"-          writeSimpleTestStub test testDir-          preProcessTest test (stubFilePath test) testDir-      TestSuiteUnsupported tt ->-          die' verbosity $ "No support for preprocessing test "-                        ++ "suite type " ++ prettyShow tt-  CBench bm@Benchmark{ benchmarkName = nm } -> do-    let nm' = unUnqualComponentName nm-    case benchmarkInterface bm of-      BenchmarkExeV10 _ f ->-          preProcessBench bm f $ buildDir lbi </> nm' </> nm' ++ "-tmp"-      BenchmarkUnsupported tt ->-          die' verbosity $ "No support for preprocessing benchmark "-                        ++ "type " ++ prettyShow tt-  where-    builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"]-    builtinCSuffixes       = cSourceExtensions-    builtinSuffixes        = builtinHaskellSuffixes ++ builtinCSuffixes-    localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers]-    pre dirs dir lhndlrs fp =-      preprocessFile (map unsafeMakeSymbolicPath dirs) dir isSrcDist fp verbosity builtinSuffixes lhndlrs-    preProcessTest test = preProcessComponent (testBuildInfo test)-                          (testModules test)-    preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm)-                         (benchmarkModules bm)--    preProcessComponent-        :: BuildInfo-        -> [ModuleName]-        -> FilePath-        -> FilePath-        -> IO ()-    preProcessComponent bi modules exePath dir = do-        let biHandlers = localHandlers bi-            sourceDirs = map getSymbolicPath (hsSourceDirs bi) ++ [ autogenComponentModulesDir lbi clbi-                                            , autogenPackageModulesDir lbi ]-        sequence_ [ preprocessFile (map unsafeMakeSymbolicPath sourceDirs) dir isSrcDist-                (ModuleName.toFilePath modu) verbosity builtinSuffixes-                biHandlers-                | modu <- modules ]--        -- XXX: what we do here (re SymbolicPath dir)-        -- XXX: 2020-10-15 do we rely here on CWD being the PackageDir?-        preprocessFile (unsafeMakeSymbolicPath dir : hsSourceDirs bi) dir isSrcDist-            (dropExtensions $ exePath) verbosity-            builtinSuffixes biHandlers----TODO: try to list all the modules that could not be found---      not just the first one. It's annoying and slow due to the need---      to reconfigure after editing the .cabal file each time.---- |Find the first extension of the file that exists, and preprocess it--- if required.-preprocessFile-    :: [SymbolicPath PackageDir SourceDir] -- ^ source directories--    -> FilePath                 -- ^build directory-    -> Bool                     -- ^preprocess for sdist-    -> FilePath                 -- ^module file name-    -> Verbosity                -- ^verbosity-    -> [String]                 -- ^builtin suffixes-    -> [(String, PreProcessor)] -- ^possible preprocessors-    -> IO ()-preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers = do-    -- look for files in the various source dirs with this module name-    -- and a file extension of a known preprocessor-    psrcFiles <- findFileWithExtension' (map fst handlers) (map getSymbolicPath searchLoc) baseFile-    case psrcFiles of-        -- no preprocessor file exists, look for an ordinary source file-        -- just to make sure one actually exists at all for this module.-        -- Note: by looking in the target/output build dir too, we allow-        -- source files to appear magically in the target build dir without-        -- any corresponding "real" source file. This lets custom Setup.hs-        -- files generate source modules directly into the build dir without-        -- the rest of the build system being aware of it (somewhat dodgy)-      Nothing -> do-                 bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : map getSymbolicPath searchLoc) baseFile-                 case bsrcFiles of-                  Nothing ->-                    die' verbosity $ "can't find source for " ++ baseFile-                                  ++ " in " ++ intercalate ", " (map getSymbolicPath searchLoc)-                  _       -> return ()-        -- found a pre-processable file in one of the source dirs-      Just (psrcLoc, psrcRelFile) -> do-            let (srcStem, ext) = splitExtension psrcRelFile-                psrcFile = psrcLoc </> psrcRelFile-                pp = fromMaybe (error "Distribution.Simple.PreProcess: Just expected")-                               (lookup (safeTail ext) handlers)-            -- Preprocessing files for 'sdist' is different from preprocessing-            -- for 'build'.  When preprocessing for sdist we preprocess to-            -- avoid that the user has to have the preprocessors available.-            -- ATM, we don't have a way to specify which files are to be-            -- preprocessed and which not, so for sdist we only process-            -- platform independent files and put them into the 'buildLoc'-            -- (which we assume is set to the temp. directory that will become-            -- the tarball).-            --TODO: eliminate sdist variant, just supply different handlers-            when (not forSDist || forSDist && platformIndependent pp) $ do-              -- look for existing pre-processed source file in the dest dir to-              -- see if we really have to re-run the preprocessor.-              ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile-              recomp <- case ppsrcFiles of-                          Nothing -> return True-                          Just ppsrcFile ->-                              psrcFile `moreRecentFile` ppsrcFile-              when recomp $ do-                let destDir = buildLoc </> dirName srcStem-                createDirectoryIfMissingVerbose verbosity True destDir-                runPreProcessorWithHsBootHack pp-                   (psrcLoc, psrcRelFile)-                   (buildLoc, srcStem <.> "hs")--  where-    dirName = takeDirectory--    -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files-    -- be in the same place as the hs files, so if we put the hs file in dist/-    -- then we need to copy the hs-boot file there too. This should probably be-    -- done another way. Possibly we should also be looking for .lhs-boot-    -- files, but I think that preprocessors only produce .hs files.-    runPreProcessorWithHsBootHack pp-      (inBaseDir,  inRelativeFile)-      (outBaseDir, outRelativeFile) = do-        runPreProcessor pp-          (inBaseDir, inRelativeFile)-          (outBaseDir, outRelativeFile) verbosity--        exists <- doesFileExist inBoot-        when exists $ copyFileVerbose verbosity inBoot outBoot--      where-        inBoot  = replaceExtension inFile  "hs-boot"-        outBoot = replaceExtension outFile "hs-boot"--        inFile  = normalise (inBaseDir  </> inRelativeFile)-        outFile = normalise (outBaseDir </> outRelativeFile)---- --------------------------------------------------------------- * known preprocessors--- --------------------------------------------------------------ppGreenCard :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor-ppGreenCard _ lbi _-    = PreProcessor {-        platformIndependent = False,-        runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->-          runDbProgram verbosity greencardProgram (withPrograms lbi)-              (["-tffi", "-o" ++ outFile, inFile])-      }---- This one is useful for preprocessors that can't handle literate source.--- We also need a way to chain preprocessors.-ppUnlit :: PreProcessor-ppUnlit =-  PreProcessor {-    platformIndependent = True,-    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->-      withUTF8FileContents inFile $ \contents ->-        either (writeUTF8File outFile) (die' verbosity) (unlit inFile contents)-  }--ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor-ppCpp = ppCpp' []--ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor-ppCpp' extraArgs bi lbi clbi =-  case compilerFlavor (compiler lbi) of-    GHC   -> ppGhcCpp ghcProgram   (const True) args bi lbi clbi-    GHCJS -> ppGhcCpp ghcjsProgram (const True) args bi lbi clbi-    _     -> ppCpphs  args bi lbi clbi-  where cppArgs = getCppOptions bi lbi-        args    = cppArgs ++ extraArgs--ppGhcCpp :: Program -> (Version -> Bool)-         -> [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor-ppGhcCpp program xHs extraArgs _bi lbi clbi =-  PreProcessor {-    platformIndependent = False,-    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do-      (prog, version, _) <- requireProgramVersion verbosity-                              program anyVersion (withPrograms lbi)-      runProgram verbosity prog $-          ["-E", "-cpp"]-          -- This is a bit of an ugly hack. We're going to-          -- unlit the file ourselves later on if appropriate,-          -- so we need GHC not to unlit it now or it'll get-          -- double-unlitted. In the future we might switch to-          -- using cpphs --unlit instead.-       ++ (if xHs version then ["-x", "hs"] else [])-       ++ [ "-optP-include", "-optP"++ (autogenComponentModulesDir lbi clbi </> cppHeaderName) ]-       ++ ["-o", outFile, inFile]-       ++ extraArgs-  }--ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor-ppCpphs extraArgs _bi lbi clbi =-  PreProcessor {-    platformIndependent = False,-    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do-      (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity-                                        cpphsProgram anyVersion (withPrograms lbi)-      runProgram verbosity cpphsProg $-          ("-O" ++ outFile) : inFile-        : "--noline" : "--strip"-        : (if cpphsVersion >= mkVersion [1,6]-             then ["--include="++ (autogenComponentModulesDir lbi clbi </> cppHeaderName)]-             else [])-        ++ extraArgs-  }--ppHsc2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor-ppHsc2hs bi lbi clbi =-  PreProcessor {-    platformIndependent = False,-    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do-      (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)-      (hsc2hsProg, hsc2hsVersion, _) <- requireProgramVersion verbosity-                                          hsc2hsProgram anyVersion (withPrograms lbi)-      -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122.-      let isCross = hostPlatform lbi /= buildPlatform-          prependCrossFlags = if isCross then ("-x":) else id-      let hsc2hsSupportsResponseFiles = hsc2hsVersion >= mkVersion [0,68,4]-          pureArgs = genPureArgs hsc2hsVersion gccProg inFile outFile-      if hsc2hsSupportsResponseFiles-      then withResponseFile-             verbosity-             defaultTempFileOptions-             (takeDirectory outFile)-             "hsc2hs-response.txt"-             Nothing-             pureArgs-             (\responseFileName ->-                runProgram verbosity hsc2hsProg (prependCrossFlags ["@"++ responseFileName]))-      else runProgram verbosity hsc2hsProg (prependCrossFlags pureArgs)-  }-  where-    -- Returns a list of command line arguments that can either be passed-    -- directly, or via a response file.-    genPureArgs :: Version -> ConfiguredProgram -> String -> String -> [String]-    genPureArgs hsc2hsVersion gccProg inFile outFile =-          -- Additional gcc options-          [ "--cflag=" ++ opt | opt <- programDefaultArgs  gccProg-                                    ++ programOverrideArgs gccProg ]-       ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs  gccProg-                                    ++ programOverrideArgs gccProg ]--          -- OSX frameworks:-       ++ [ what ++ "=-F" ++ opt-          | isOSX-          , opt <- nub (concatMap Installed.frameworkDirs pkgs)-          , what <- ["--cflag", "--lflag"] ]-       ++ [ "--lflag=" ++ arg-          | isOSX-          , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs-          , arg <- ["-framework", opt] ]--          -- Note that on ELF systems, wherever we use -L, we must also use -R-          -- because presumably that -L dir is not on the normal path for the-          -- system's dynamic linker. This is needed because hsc2hs works by-          -- compiling a C program and then running it.--       ++ [ "--cflag="   ++ opt | opt <- platformDefines lbi ]--          -- Options from the current package:-       ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs  bi ]-       ++ [ "--cflag=-I" ++ buildDir lbi </> dir | dir <- PD.includeDirs bi ]-       ++ [ "--cflag="   ++ opt | opt <- PD.ccOptions    bi-                                      ++ PD.cppOptions   bi-                                      -- hsc2hs uses the C ABI-                                      -- We assume that there are only C sources-                                      -- and C++ functions are exported via a C-                                      -- interface and wrapped in a C source file.-                                      -- Therefore we do not supply C++ flags-                                      -- because there will not be C++ sources.-                                      ---                                      -- DO NOT add PD.cxxOptions unless this changes!-                                      ]-       ++ [ "--cflag="   ++ opt | opt <--               [ "-I" ++ autogenComponentModulesDir lbi clbi,-                 "-I" ++ autogenPackageModulesDir lbi,-                 "-include", autogenComponentModulesDir lbi clbi </> cppHeaderName ] ]-       ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ]-       ++ [ "--lflag=-Wl,-R," ++ opt | isELF-                                , opt <- PD.extraLibDirs bi ]-       ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs    bi ]-       ++ [ "--lflag="   ++ opt | opt <- PD.ldOptions    bi ]--          -- Options from dependent packages-       ++ [ "--cflag=" ++ opt-          | pkg <- pkgs-          , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ]-                ++ [         opt | opt <- Installed.ccOptions   pkg ] ]-       ++ [ "--lflag=" ++ opt-          | pkg <- pkgs-          , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs    pkg ]-                ++ [ "-Wl,-R," ++ opt | isELF-                                 , opt <- Installed.libraryDirs    pkg ]-                ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ]-                ++ [         opt | opt <- Installed.ldOptions      pkg ] ]-       ++ preccldFlags-       ++ hsc2hsOptions bi-       ++ postccldFlags--       ++ ["-o", outFile, inFile]-      where-        -- hsc2hs flag parsing was wrong-        -- (see -- https://github.com/haskell/hsc2hs/issues/35)-        -- so we need to put -- --cc/--ld *after* hsc2hsOptions,-        -- for older hsc2hs (pre 0.68.8) so that they can be overridden.-        ccldFlags =-          [ "--cc=" ++ programPath gccProg-          , "--ld=" ++ programPath gccProg-          ]--        (preccldFlags, postccldFlags)-          | hsc2hsVersion >= mkVersion [0,68,8] = (ccldFlags, [])-          | otherwise                           = ([], ccldFlags)--    hacked_index = packageHacks (installedPkgs lbi)-    -- Look only at the dependencies of the current component-    -- being built!  This relies on 'installedPkgs' maintaining-    -- 'InstalledPackageInfo' for internal deps too; see #2971.-    pkgs = PackageIndex.topologicalOrder $-           case PackageIndex.dependencyClosure hacked_index-                    (map fst (componentPackageDeps clbi)) of-            Left index' -> index'-            Right inf ->-                error ("ppHsc2hs: broken closure: " ++ show inf)-    isOSX = case buildOS of OSX -> True; _ -> False-    isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True;-    packageHacks = case compilerFlavor (compiler lbi) of-      GHC   -> hackRtsPackage-      GHCJS -> hackRtsPackage-      _     -> id-    -- We don't link in the actual Haskell libraries of our dependencies, so-    -- the -u flags in the ldOptions of the rts package mean linking fails on-    -- OS X (its ld is a tad stricter than gnu ld). Thus we remove the-    -- ldOptions for GHC's rts package:-    hackRtsPackage index =-      case PackageIndex.lookupPackageName index (mkPackageName "rts") of-        [(_, [rts])]-           -> PackageIndex.insert rts { Installed.ldOptions = [] } index-        _  -> error "No (or multiple) ghc rts package is registered!!"--ppHsc2hsExtras :: PreProcessorExtras-ppHsc2hsExtras buildBaseDir = filter ("_hsc.c" `isSuffixOf`) `fmap`-                              getDirectoryContentsRecursive buildBaseDir--ppC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor-ppC2hs bi lbi clbi =-  PreProcessor {-    platformIndependent = False,-    runPreProcessor = \(inBaseDir, inRelativeFile)-                       (outBaseDir, outRelativeFile) verbosity -> do-      (c2hsProg, _, _) <- requireProgramVersion verbosity-                            c2hsProgram (orLaterVersion (mkVersion [0,15]))-                            (withPrograms lbi)-      (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)-      runProgram verbosity c2hsProg $--          -- Options from the current package:-           [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ]-        ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ]-        ++ [ "--cppopts=-include" ++ (autogenComponentModulesDir lbi clbi </> cppHeaderName) ]-        ++ [ "--include=" ++ outBaseDir ]--          -- Options from dependent packages-       ++ [ "--cppopts=" ++ opt-          | pkg <- pkgs-          , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ]-                ++ [         opt | opt@('-':c:_) <- Installed.ccOptions pkg-                                                 -- c2hs uses the C ABI-                                                 -- We assume that there are only C sources-                                                 -- and C++ functions are exported via a C-                                                 -- interface and wrapped in a C source file.-                                                 -- Therefore we do not supply C++ flags-                                                 -- because there will not be C++ sources.-                                                 ---                                                 ---                                                 -- DO NOT add Installed.cxxOptions unless this changes!-                                 , c `elem` "DIU" ] ]-          --TODO: install .chi files for packages, so we can --include-          -- those dirs here, for the dependencies--           -- input and output files-        ++ [ "--output-dir=" ++ outBaseDir-           , "--output=" ++ outRelativeFile-           , inBaseDir </> inRelativeFile ]-  }-  where-    pkgs = PackageIndex.topologicalOrder (installedPkgs lbi)--ppC2hsExtras :: PreProcessorExtras-ppC2hsExtras d = filter (\p -> takeExtensions p == ".chs.c") `fmap`-                 getDirectoryContentsRecursive d----TODO: perhaps use this with hsc2hs too---TODO: remove cc-options from cpphs for cabal-version: >= 1.10---TODO: Refactor and add separate getCppOptionsForHs, getCppOptionsForCxx, & getCppOptionsForC---      instead of combining all these cases in a single function. This blind combination can---      potentially lead to compilation inconsistencies.-getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]-getCppOptions bi lbi-    = platformDefines lbi-   ++ cppOptions bi-   ++ ["-I" ++ dir | dir <- PD.includeDirs bi]-   ++ [opt | opt@('-':c:_) <- PD.ccOptions bi ++ PD.cxxOptions bi, c `elem` "DIU"]--platformDefines :: LocalBuildInfo -> [String]-platformDefines lbi =-  case compilerFlavor comp of-    GHC  ->-      ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++-      ["-D" ++ os   ++ "_BUILD_OS=1"] ++-      ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++-      map (\os'   -> "-D" ++ os'   ++ "_HOST_OS=1")   osStr ++-      map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr-    GHCJS ->-      compatGlasgowHaskell ++-      ["-D__GHCJS__=" ++ versionInt version] ++-      ["-D" ++ os   ++ "_BUILD_OS=1"] ++-      ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++-      map (\os'   -> "-D" ++ os'   ++ "_HOST_OS=1")   osStr ++-      map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr-    HaskellSuite {} ->-      ["-D__HASKELL_SUITE__"] ++-        map (\os'   -> "-D" ++ os'   ++ "_HOST_OS=1")   osStr ++-        map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr-    _    -> []-  where-    comp = compiler lbi-    Platform hostArch hostOS = hostPlatform lbi-    version = compilerVersion comp-    compatGlasgowHaskell =-      maybe [] (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v])-               (compilerCompatVersion GHC comp)-    -- TODO: move this into the compiler abstraction-    -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all-    -- the other compilers. Check if that's really what they want.-    versionInt :: Version -> String-    versionInt v = case versionNumbers v of-      [] -> "1"-      [n] -> show n-      n1:n2:_ ->-        -- 6.8.x -> 608-        -- 6.10.x -> 610-        let s1 = show n1-            s2 = show n2-            middle = case s2 of-                     _ : _ : _ -> ""-                     _         -> "0"-        in s1 ++ middle ++ s2--    osStr = case hostOS of-      Linux     -> ["linux"]-      Windows   -> ["mingw32"]-      OSX       -> ["darwin"]-      FreeBSD   -> ["freebsd"]-      OpenBSD   -> ["openbsd"]-      NetBSD    -> ["netbsd"]-      DragonFly -> ["dragonfly"]-      Solaris   -> ["solaris2"]-      AIX       -> ["aix"]-      HPUX      -> ["hpux"]-      IRIX      -> ["irix"]-      HaLVM     -> []-      IOS       -> ["ios"]-      Android   -> ["android"]-      Ghcjs     -> ["ghcjs"]-      Hurd      -> ["hurd"]-      OtherOS _ -> []-    archStr = case hostArch of-      I386        -> ["i386"]-      X86_64      -> ["x86_64"]-      PPC         -> ["powerpc"]-      PPC64       -> ["powerpc64"]-      Sparc       -> ["sparc"]-      Arm         -> ["arm"]-      AArch64     -> ["aarch64"]-      Mips        -> ["mips"]-      SH          -> []-      IA64        -> ["ia64"]-      S390        -> ["s390"]-      Alpha       -> ["alpha"]-      Hppa        -> ["hppa"]-      Rs6000      -> ["rs6000"]-      M68k        -> ["m68k"]-      Vax         -> ["vax"]-      JavaScript  -> ["javascript"]-      OtherArch _ -> []--ppHappy :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor-ppHappy _ lbi _ = pp { platformIndependent = True }-  where pp = standardPP lbi happyProgram (hcFlags hc)-        hc = compilerFlavor (compiler lbi)-        hcFlags GHC = ["-agc"]-        hcFlags GHCJS = ["-agc"]-        hcFlags _ = []--ppAlex :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor-ppAlex _ lbi _ = pp { platformIndependent = True }-  where pp = standardPP lbi alexProgram (hcFlags hc)-        hc = compilerFlavor (compiler lbi)-        hcFlags GHC = ["-g"]-        hcFlags GHCJS = ["-g"]-        hcFlags _ = []--standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor-standardPP lbi prog args =-  PreProcessor {-    platformIndependent = False,-    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->-      runDbProgram verbosity prog (withPrograms lbi)-                           (args ++ ["-o", outFile, inFile])-  }---- |Convenience function; get the suffixes of these preprocessors.-ppSuffixes :: [ PPSuffixHandler ] -> [String]-ppSuffixes = map fst---- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs.-knownSuffixHandlers :: [ PPSuffixHandler ]-knownSuffixHandlers =-  [ ("gc",     ppGreenCard)-  , ("chs",    ppC2hs)-  , ("hsc",    ppHsc2hs)-  , ("x",      ppAlex)-  , ("y",      ppHappy)-  , ("ly",     ppHappy)-  , ("cpphs",  ppCpp)-  ]---- |Standard preprocessors with possible extra C sources: c2hs, hsc2hs.-knownExtrasHandlers :: [ PreProcessorExtras ]-knownExtrasHandlers = [ ppC2hsExtras, ppHsc2hsExtras ]---- | Find any extra C sources generated by preprocessing that need to--- be added to the component (addresses issue #238).-preprocessExtras :: Verbosity-                 -> Component-                 -> LocalBuildInfo-                 -> IO [FilePath]-preprocessExtras verbosity comp lbi = case comp of-  CLib _ -> pp $ buildDir lbi-  (CExe Executable { exeName = nm }) -> do-    let nm' = unUnqualComponentName nm-    pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"-  (CFLib ForeignLib { foreignLibName = nm }) -> do-    let nm' = unUnqualComponentName nm-    pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"-  CTest test -> do-    let nm' = unUnqualComponentName $ testName test-    case testInterface test of-      TestSuiteExeV10 _ _ ->-          pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"-      TestSuiteLibV09 _ _ ->-          pp $ buildDir lbi </> stubName test </> stubName test ++ "-tmp"-      TestSuiteUnsupported tt ->-        die' verbosity $ "No support for preprocessing test suite type " ++-                         prettyShow tt-  CBench bm -> do-    let nm' = unUnqualComponentName $ benchmarkName bm-    case benchmarkInterface bm of-      BenchmarkExeV10 _ _ ->-          pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"-      BenchmarkUnsupported tt ->-          die' verbosity $ "No support for preprocessing benchmark "-                        ++ "type " ++ prettyShow tt-  where-    pp :: FilePath -> IO [FilePath]-    pp dir = (map (dir </>) . filter not_sub . concat)-          <$> for knownExtrasHandlers-                (withLexicalCallStack (\f -> f dir))-    -- TODO: This is a terrible hack to work around #3545 while we don't-    -- reorganize the directory layout.  Basically, for the main-    -- library, we might accidentally pick up autogenerated sources for-    -- our subcomponents, because they are all stored as subdirectories-    -- in dist/build.  This is a cheap and cheerful check to prevent-    -- this from happening.  It is not particularly correct; for example-    -- if a user has a test suite named foobar and puts their C file in-    -- foobar/foo.c, this test will incorrectly exclude it.  But I-    -- didn't want to break BC...-    not_sub p = and [ not (pre `isPrefixOf` p) | pre <- component_dirs ]-    component_dirs = component_names (localPkgDescr lbi)-    -- TODO: libify me-    component_names pkg_descr = fmap unUnqualComponentName $-        mapMaybe (libraryNameString . libName) (subLibraries pkg_descr) ++-        map exeName (executables pkg_descr) ++-        map testName (testSuites pkg_descr) ++-        map benchmarkName (benchmarks pkg_descr)+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.PreProcess+-- Copyright   :  (c) 2003-2005, Isaac Jones, Malcolm Wallace+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module defines 'PPSuffixHandler', which is a combination of a file+-- extension and a function for configuring a 'PreProcessor'. It also defines+-- a bunch of known built-in preprocessors like @cpp@, @cpphs@, @c2hs@,+-- @hsc2hs@, @happy@, @alex@ etc and lists them in 'knownSuffixHandlers'.+-- On top of this it provides a function for actually preprocessing some sources+-- given a bunch of known suffix handlers.+-- This module is not as good as it could be, it could really do with a rewrite+-- to address some of the problems we have with pre-processors.+module Distribution.Simple.PreProcess+  ( preprocessComponent+  , preprocessExtras+  , preprocessFile+  , knownSuffixHandlers+  , ppSuffixes+  , PPSuffixHandler+  , Suffix (..)+  , builtinHaskellSuffixes+  , builtinHaskellBootSuffixes+  , PreProcessor (..)+  , mkSimplePreProcessor+  , runSimplePreProcessor+  , ppCpp+  , ppCpp'+  , ppC2hs+  , ppHsc2hs+  , ppHappy+  , ppAlex+  , ppUnlit+  , platformDefines+  , unsorted+  )+where++import Distribution.Compat.Prelude+import Distribution.Compat.Stack+import Prelude ()++import Distribution.Backpack.DescribeUnitId+import qualified Distribution.InstalledPackageInfo as Installed+import Distribution.ModuleName (ModuleName)+import Distribution.Package+import Distribution.PackageDescription as PD+import Distribution.Simple.BuildPaths+import Distribution.Simple.CCompiler+import Distribution.Simple.Compiler+import Distribution.Simple.Errors+import Distribution.Simple.LocalBuildInfo+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PreProcess.Types+import Distribution.Simple.PreProcess.Unlit+import Distribution.Simple.Program+import Distribution.Simple.Program.ResponseFile+import Distribution.Simple.Test.LibV09+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Types.PackageName.Magic+import Distribution.Utils.Path+import Distribution.Verbosity+import Distribution.Version++import System.Directory (doesDirectoryExist, doesFileExist)+import System.FilePath+  ( normalise+  , replaceExtension+  , splitExtension+  , takeDirectory+  , takeExtensions+  )+import System.Info (arch, os)++-- | Just present the modules in the order given; this is the default and it is+-- appropriate for preprocessors which do not have any sort of dependencies+-- between modules.+unsorted+  :: Verbosity+  -> [path]+  -> [ModuleName]+  -> IO [ModuleName]+unsorted _ _ ms = pure ms++-- | Function to determine paths to possible extra C sources for a+-- preprocessor: just takes the path to the build directory and uses+-- this to search for C sources with names that match the+-- preprocessor's output name format.+type PreProcessorExtras =+  Maybe (SymbolicPath CWD (Dir Pkg))+  -> SymbolicPath Pkg (Dir Source)+  -> IO [RelativePath Source File]++mkSimplePreProcessor+  :: (FilePath -> FilePath -> Verbosity -> IO ())+  -> (FilePath, FilePath)+  -> (FilePath, FilePath)+  -> Verbosity+  -> IO ()+mkSimplePreProcessor+  simplePP+  (inBaseDir, inRelativeFile)+  (outBaseDir, outRelativeFile)+  verbosity = simplePP inFile outFile verbosity+    where+      inFile = normalise (inBaseDir </> inRelativeFile)+      outFile = normalise (outBaseDir </> outRelativeFile)++runSimplePreProcessor+  :: PreProcessor+  -> FilePath+  -> FilePath+  -> Verbosity+  -> IO ()+runSimplePreProcessor pp inFile outFile verbosity =+  runPreProcessor pp (".", inFile) (".", outFile) verbosity++-- | A preprocessor for turning non-Haskell files with the given 'Suffix'+-- (i.e. file extension) into plain Haskell source files.+type PPSuffixHandler =+  (Suffix, BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor)++-- | Apply preprocessors to the sources from 'hsSourceDirs' for a given+-- component (lib, exe, or test suite).+--+-- XXX: This is terrible+preprocessComponent+  :: PackageDescription+  -> Component+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> Bool+  -> Verbosity+  -> [PPSuffixHandler]+  -> IO ()+preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers =+  -- Skip preprocessing for scripts since they should be regular Haskell files,+  -- but may have no or unknown extensions.+  when (package pd /= fakePackageId) $ do+    -- NB: never report instantiation here; we'll report it properly when+    -- building.+    setupMessage'+      verbosity+      "Preprocessing"+      (packageId pd)+      (componentLocalName clbi)+      (Nothing :: Maybe [(ModuleName, Module)])+    case comp of+      (CLib lib@Library{libBuildInfo = bi}) -> do+        let dirs =+              hsSourceDirs bi+                ++ [autogenComponentModulesDir lbi clbi, autogenPackageModulesDir lbi]+        let hndlrs = localHandlers bi+        mods <- orderingFromHandlers verbosity dirs hndlrs (allLibModules lib clbi)+        for_ (map moduleNameSymbolicPath mods) $+          pre dirs (componentBuildDir lbi clbi) hndlrs+      (CFLib flib@ForeignLib{foreignLibBuildInfo = bi}) -> do+        let flibDir = flibBuildDir lbi flib+            dirs =+              hsSourceDirs bi+                ++ [ autogenComponentModulesDir lbi clbi+                   , autogenPackageModulesDir lbi+                   ]+        let hndlrs = localHandlers bi+        mods <- orderingFromHandlers verbosity dirs hndlrs (foreignLibModules flib)+        for_ (map moduleNameSymbolicPath mods) $+          pre dirs flibDir hndlrs+      (CExe exe@Executable{buildInfo = bi}) -> do+        let exeDir = exeBuildDir lbi exe+            dirs =+              hsSourceDirs bi+                ++ [ autogenComponentModulesDir lbi clbi+                   , autogenPackageModulesDir lbi+                   ]+        let hndlrs = localHandlers bi+        mods <- orderingFromHandlers verbosity dirs hndlrs (otherModules bi)+        for_ (map moduleNameSymbolicPath mods) $+          pre dirs exeDir hndlrs+        pre (hsSourceDirs bi) exeDir (localHandlers bi) $+          dropExtensionsSymbolicPath (modulePath exe)+      CTest test@TestSuite{} -> do+        let testDir = testBuildDir lbi test+        case testInterface test of+          TestSuiteExeV10 _ f ->+            preProcessTest test f testDir+          TestSuiteLibV09 _ _ -> do+            writeSimpleTestStub test (i testDir)+            preProcessTest test (makeRelativePathEx $ stubFilePath test) testDir+          TestSuiteUnsupported tt ->+            dieWithException verbosity $ NoSupportForPreProcessingTest tt+      CBench bm@Benchmark{} -> do+        let benchDir = benchmarkBuildDir lbi bm+        case benchmarkInterface bm of+          BenchmarkExeV10 _ f ->+            preProcessBench bm f benchDir+          BenchmarkUnsupported tt ->+            dieWithException verbosity $ NoSupportForPreProcessingBenchmark tt+  where+    orderingFromHandlers v d hndlrs mods =+      foldM (\acc (_, pp) -> ppOrdering pp v d acc) mods hndlrs+    builtinCSuffixes = map Suffix cSourceExtensions+    builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes+    localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers]+    mbWorkDir = mbWorkDirLBI lbi+    i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path+    pre dirs dir lhndlrs fp =+      preprocessFile mbWorkDir dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs True+    preProcessTest test =+      preProcessComponent+        (testBuildInfo test)+        (testModules test)+    preProcessBench bm =+      preProcessComponent+        (benchmarkBuildInfo bm)+        (benchmarkModules bm)++    preProcessComponent+      :: BuildInfo+      -> [ModuleName]+      -> RelativePath Source File+      -> SymbolicPath Pkg (Dir Build)+      -> IO ()+    preProcessComponent bi modules exePath outputDir = do+      let biHandlers = localHandlers bi+          sourceDirs =+            hsSourceDirs bi+              ++ [ autogenComponentModulesDir lbi clbi+                 , autogenPackageModulesDir lbi+                 ]+      sequence_+        [ preprocessFile+          mbWorkDir+          sourceDirs+          outputDir+          isSrcDist+          (moduleNameSymbolicPath modu)+          verbosity+          builtinSuffixes+          biHandlers+          False+        | modu <- modules+        ]+      -- Note we don't fail on missing in this case, because the main file+      -- may be generated later (i.e. by a test code generator)+      preprocessFile+        mbWorkDir+        (coerceSymbolicPath outputDir : hsSourceDirs bi)+        outputDir+        isSrcDist+        (dropExtensionsSymbolicPath $ exePath)+        verbosity+        builtinSuffixes+        biHandlers+        False++-- TODO: try to list all the modules that could not be found+--      not just the first one. It's annoying and slow due to the need+--      to reconfigure after editing the .cabal file each time.++-- | Find the first extension of the file that exists, and preprocess it+-- if required.+preprocessFile+  :: Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ package directory location+  -> [SymbolicPath Pkg (Dir Source)]+  -- ^ source directories+  -> SymbolicPath Pkg (Dir Build)+  -- ^ build directory+  -> Bool+  -- ^ preprocess for sdist+  -> RelativePath Source File+  -- ^ module file name+  -> Verbosity+  -- ^ verbosity+  -> [Suffix]+  -- ^ builtin suffixes+  -> [(Suffix, PreProcessor)]+  -- ^ possible preprocessors+  -> Bool+  -- ^ fail on missing file+  -> IO ()+preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do+  -- look for files in the various source dirs with this module name+  -- and a file extension of a known preprocessor+  psrcFiles <- findFileCwdWithExtension' mbWorkDir (map fst handlers) searchLoc baseFile+  case psrcFiles of+    -- no preprocessor file exists, look for an ordinary source file+    -- just to make sure one actually exists at all for this module.++    -- Note [Dodgy build dirs for preprocessors]+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -- By looking in the target/output build dir too, we allow+    -- source files to appear magically in the target build dir without+    -- any corresponding "real" source file. This lets custom Setup.hs+    -- files generate source modules directly into the build dir without+    -- the rest of the build system being aware of it (somewhat dodgy)+    Nothing -> do+      bsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes (buildAsSrcLoc : searchLoc) baseFile+      case (bsrcFiles, failOnMissing) of+        (Nothing, True) ->+          dieWithException verbosity $+            CantFindSourceForPreProcessFile $+              "can't find source for "+                ++ getSymbolicPath baseFile+                ++ " in "+                ++ intercalate ", " (map getSymbolicPath searchLoc)+        _ -> return ()+    -- found a pre-processable file in one of the source dirs+    Just (psrcLoc, psrcRelFile) -> do+      let (srcStem, ext) = splitExtension $ getSymbolicPath psrcRelFile+          psrcFile = psrcLoc </> psrcRelFile+          pp =+            fromMaybe+              (error "Distribution.Simple.PreProcess: Just expected")+              (lookup (Suffix $ safeTail ext) handlers)+      -- Preprocessing files for 'sdist' is different from preprocessing+      -- for 'build'.  When preprocessing for sdist we preprocess to+      -- avoid that the user has to have the preprocessors available.+      -- ATM, we don't have a way to specify which files are to be+      -- preprocessed and which not, so for sdist we only process+      -- platform independent files and put them into the 'buildLoc'+      -- (which we assume is set to the temp. directory that will become+      -- the tarball).+      -- TODO: eliminate sdist variant, just supply different handlers+      when (not forSDist || forSDist && platformIndependent pp) $ do+        -- look for existing pre-processed source file in the dest dir to+        -- see if we really have to re-run the preprocessor.+        ppsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes [buildAsSrcLoc] baseFile+        recomp <- case ppsrcFiles of+          Nothing -> return True+          Just ppsrcFile ->+            i psrcFile `moreRecentFile` i ppsrcFile+        when recomp $ do+          let destDir = i buildLoc </> takeDirectory srcStem+          createDirectoryIfMissingVerbose verbosity True destDir+          runPreProcessorWithHsBootHack+            pp+            (psrcLoc, getSymbolicPath $ psrcRelFile)+            (buildLoc, srcStem <.> "hs")+  where+    i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path+    buildAsSrcLoc :: SymbolicPath Pkg (Dir Source)+    buildAsSrcLoc = coerceSymbolicPath buildLoc++    -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files+    -- be in the same place as the hs files, so if we put the hs file in dist/+    -- then we need to copy the hs-boot file there too. This should probably be+    -- done another way. Possibly we should also be looking for .lhs-boot+    -- files, but I think that preprocessors only produce .hs files.+    runPreProcessorWithHsBootHack+      pp+      (inBaseDir, inRelativeFile)+      (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+          (getSymbolicPath $ inBaseDir, inRelativeFile)+          (getSymbolicPath $ outBaseDir, outRelativeFile)+          verbosity++        -- 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"+        exists <- doesFileExist inBoot+        when exists $ copyFileVerbose verbosity inBoot outBoot++-- ------------------------------------------------------------++-- * known preprocessors++-- ------------------------------------------------------------++-- This one is useful for preprocessors that can't handle literate source.+-- We also need a way to chain preprocessors.+ppUnlit :: PreProcessor+ppUnlit =+  PreProcessor+    { platformIndependent = True+    , ppOrdering = unsorted+    , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->+        withUTF8FileContents inFile $ \contents ->+          either (writeUTF8File outFile) (dieWithException verbosity) (unlit inFile contents)+    }++ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppCpp = ppCpp' []++ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppCpp' extraArgs bi lbi clbi =+  case compilerFlavor (compiler lbi) of+    GHC -> ppGhcCpp ghcProgram (const True) args bi lbi clbi+    GHCJS -> ppGhcCpp ghcjsProgram (const True) args bi lbi clbi+    _ -> ppCpphs args bi lbi clbi+  where+    cppArgs = getCppOptions bi lbi+    args = cppArgs ++ extraArgs++ppGhcCpp+  :: Program+  -> (Version -> Bool)+  -> [String]+  -> BuildInfo+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> PreProcessor+ppGhcCpp program xHs extraArgs _bi lbi clbi =+  PreProcessor+    { platformIndependent = False+    , ppOrdering = unsorted+    , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do+        (prog, version, _) <-+          requireProgramVersion+            verbosity+            program+            anyVersion+            (withPrograms lbi)+        runProgramCwd verbosity (mbWorkDirLBI lbi) prog $+          ["-E", "-cpp"]+            -- This is a bit of an ugly hack. We're going to+            -- unlit the file ourselves later on if appropriate,+            -- so we need GHC not to unlit it now or it'll get+            -- double-unlitted. In the future we might switch to+            -- using cpphs --unlit instead.+            ++ (if xHs version then ["-x", "hs"] else [])+            ++ ["-optP-include", "-optP" ++ u (autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName)]+            ++ ["-o", outFile, inFile]+            ++ extraArgs+    }+  where+    -- See Note [Symbolic paths] in Distribution.Utils.Path+    u :: SymbolicPath Pkg to -> FilePath+    u = interpretSymbolicPathCWD++ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppCpphs extraArgs _bi lbi clbi =+  PreProcessor+    { platformIndependent = False+    , ppOrdering = unsorted+    , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do+        (cpphsProg, cpphsVersion, _) <-+          requireProgramVersion+            verbosity+            cpphsProgram+            anyVersion+            (withPrograms lbi)+        runProgramCwd verbosity (mbWorkDirLBI lbi) cpphsProg $+          ("-O" ++ outFile)+            : inFile+            : "--noline"+            : "--strip"+            : ( if cpphsVersion >= mkVersion [1, 6]+                  then ["--include=" ++ u (autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName)]+                  else []+              )+            ++ extraArgs+    }+  where+    -- See Note [Symbolic paths] in Distribution.Utils.Path+    u :: SymbolicPath Pkg to -> FilePath+    u = interpretSymbolicPathCWD++ppHsc2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppHsc2hs bi lbi clbi =+  PreProcessor+    { platformIndependent = False+    , ppOrdering = unsorted+    , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do+        (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)+        (hsc2hsProg, hsc2hsVersion, _) <-+          requireProgramVersion+            verbosity+            hsc2hsProgram+            anyVersion+            (withPrograms lbi)+        let runHsc2hs = runProgramCwd verbosity mbWorkDir hsc2hsProg+        -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122.+        let isCross = hostPlatform lbi /= buildPlatform+            prependCrossFlags = if isCross then ("-x" :) else id+        let hsc2hsSupportsResponseFiles = hsc2hsVersion >= mkVersion [0, 68, 4]+            pureArgs = genPureArgs hsc2hsVersion gccProg inFile outFile+        if hsc2hsSupportsResponseFiles+          then+            withResponseFile+              verbosity+              defaultTempFileOptions+              "hsc2hs-response.txt"+              Nothing+              pureArgs+              ( \responseFileName ->+                  runHsc2hs (prependCrossFlags ["@" ++ responseFileName])+              )+          else runHsc2hs (prependCrossFlags pureArgs)+    }+  where+    -- See Note [Symbolic paths] in Distribution.Utils.Path+    u :: SymbolicPathX allowAbs Pkg to -> FilePath+    u = interpretSymbolicPathCWD+    mbWorkDir = mbWorkDirLBI lbi++    -- Returns a list of command line arguments that can either be passed+    -- directly, or via a response file.+    genPureArgs :: Version -> ConfiguredProgram -> String -> String -> [String]+    genPureArgs hsc2hsVersion gccProg inFile outFile =+      -- Additional gcc options+      [ "--cflag=" ++ opt+      | opt <-+          programDefaultArgs gccProg+            ++ programOverrideArgs gccProg+      ]+        ++ [ "--lflag=" ++ opt+           | opt <-+              programDefaultArgs gccProg+                ++ programOverrideArgs gccProg+           ]+        -- OSX frameworks:+        ++ [ what ++ "=-F" ++ opt+           | isOSX+           , opt <- nub (concatMap Installed.frameworkDirs pkgs)+           , what <- ["--cflag", "--lflag"]+           ]+        ++ [ "--lflag=" ++ arg+           | isOSX+           , opt <- 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+           ]+        ++ preccldFlags+        ++ hsc2hsOptions bi+        ++ postccldFlags+        ++ ["-o", outFile, inFile]+      where+        -- hsc2hs flag parsing was wrong+        -- (see -- https://github.com/haskell/hsc2hs/issues/35)+        -- so we need to put -- --cc/--ld *after* hsc2hsOptions,+        -- for older hsc2hs (pre 0.68.8) so that they can be overridden.+        ccldFlags =+          [ "--cc=" ++ programPath gccProg+          , "--ld=" ++ programPath gccProg+          ]++        (preccldFlags, postccldFlags)+          | hsc2hsVersion >= mkVersion [0, 68, 8] = (ccldFlags, [])+          | otherwise = ([], ccldFlags)++    hacked_index = packageHacks (installedPkgs lbi)+    -- Look only at the dependencies of the current component+    -- being built!  This relies on 'installedPkgs' maintaining+    -- 'InstalledPackageInfo' for internal deps too; see #2971.+    pkgs = PackageIndex.topologicalOrder $+      case PackageIndex.dependencyClosure+        hacked_index+        (map fst (componentPackageDeps clbi)) of+        Left index' -> index'+        Right inf ->+          error ("ppHsc2hs: broken closure: " ++ show inf)+    isOSX = case buildOS of OSX -> True; _ -> False+    isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True+    packageHacks = case compilerFlavor (compiler lbi) of+      GHC -> hackRtsPackage+      GHCJS -> hackRtsPackage+      _ -> id+    -- We don't link in the actual Haskell libraries of our dependencies, so+    -- the -u flags in the ldOptions of the rts package mean linking fails on+    -- OS X (its ld is a tad stricter than gnu ld). Thus we remove the+    -- ldOptions for GHC's rts package:+    hackRtsPackage index =+      case PackageIndex.lookupPackageName index (mkPackageName "rts") of+        [(_, [rts])] ->+          PackageIndex.insert rts{Installed.ldOptions = []} index+        _ -> error "No (or multiple) ghc rts package is registered!!"++ppHsc2hsExtras :: PreProcessorExtras+ppHsc2hsExtras mbWorkDir buildBaseDir = do+  fs <- getDirectoryContentsRecursive $ interpretSymbolicPath mbWorkDir buildBaseDir+  let hscCFiles = filter ("_hsc.c" `isSuffixOf`) fs+  return $ map makeRelativePathEx hscCFiles++ppC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppC2hs bi lbi clbi =+  PreProcessor+    { platformIndependent = False+    , ppOrdering = unsorted+    , runPreProcessor =+        \(inBaseDir, inRelativeFile)+         (outBaseDir, outRelativeFile)+         verbosity -> do+            (c2hsProg, _, _) <-+              requireProgramVersion+                verbosity+                c2hsProgram+                (orLaterVersion (mkVersion [0, 15]))+                (withPrograms lbi)+            (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)+            runProgramCwd verbosity mbWorkDir c2hsProg $+              -- Options from the current package:+              ["--cpp=" ++ programPath gccProg, "--cppopts=-E"]+                ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi]+                ++ ["--cppopts=-include" ++ u (autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName)]+                ++ ["--include=" ++ outBaseDir]+                -- Options from dependent packages+                ++ [ "--cppopts=" ++ opt+                   | pkg <- pkgs+                   , opt <-+                      ["-I" ++ opt | opt <- Installed.includeDirs pkg]+                        ++ [ opt | opt@('-' : c : _) <- Installed.ccOptions pkg,+                           -- c2hs uses the C ABI+                           -- We assume that there are only C sources+                           -- and C++ functions are exported via a C+                           -- interface and wrapped in a C source file.+                           -- Therefore we do not supply C++ flags+                           -- because there will not be C++ sources.+                           --+                           --+                           -- DO NOT add Installed.cxxOptions unless this changes!+                           c `elem` "DIU"+                           ]+                   ]+                -- TODO: install .chi files for packages, so we can --include+                -- those dirs here, for the dependencies++                -- input and output files+                ++ [ "--output-dir=" ++ outBaseDir+                   , "--output=" ++ outRelativeFile+                   , inBaseDir </> inRelativeFile+                   ]+    }+  where+    pkgs = PackageIndex.topologicalOrder (installedPkgs lbi)+    mbWorkDir = mbWorkDirLBI lbi+    -- See Note [Symbolic paths] in Distribution.Utils.Path+    u :: SymbolicPath Pkg to -> FilePath+    u = interpretSymbolicPathCWD++ppC2hsExtras :: PreProcessorExtras+ppC2hsExtras mbWorkDir buildBaseDir = do+  fs <- getDirectoryContentsRecursive $ interpretSymbolicPath mbWorkDir buildBaseDir+  return $+    map makeRelativePathEx $+      filter (\p -> takeExtensions p == ".chs.c") fs++-- TODO: perhaps use this with hsc2hs too+-- TODO: remove cc-options from cpphs for cabal-version: >= 1.10+-- TODO: Refactor and add separate getCppOptionsForHs, getCppOptionsForCxx, & getCppOptionsForC+--      instead of combining all these cases in a single function. This blind combination can+--      potentially lead to compilation inconsistencies.+getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]+getCppOptions bi lbi =+  platformDefines lbi+    ++ cppOptions bi+    ++ ["-I" ++ getSymbolicPath dir | dir <- PD.includeDirs bi]+    ++ [opt | opt@('-' : c : _) <- PD.ccOptions bi ++ PD.cxxOptions bi, c `elem` "DIU"]++platformDefines :: LocalBuildInfo -> [String]+platformDefines lbi =+  case compilerFlavor comp of+    GHC ->+      ["-D__GLASGOW_HASKELL__=" ++ versionInt version]+        ++ ["-D" ++ os ++ "_BUILD_OS=1"]+        ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"]+        ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr+        ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr+    GHCJS ->+      compatGlasgowHaskell+        ++ ["-D__GHCJS__=" ++ versionInt version]+        ++ ["-D" ++ os ++ "_BUILD_OS=1"]+        ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"]+        ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr+        ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr+    _ -> []+  where+    comp = compiler lbi+    Platform hostArch hostOS = hostPlatform lbi+    version = compilerVersion comp+    compatGlasgowHaskell =+      maybe+        []+        (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v])+        (compilerCompatVersion GHC comp)+    -- TODO: move this into the compiler abstraction+    -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all+    -- the other compilers. Check if that's really what they want.+    versionInt :: Version -> String+    versionInt v = case versionNumbers v of+      [] -> "1"+      [n] -> show n+      n1 : n2 : _ ->+        -- 6.8.x -> 608+        -- 6.10.x -> 610+        let s1 = show n1+            s2 = show n2+            middle = case s2 of+              _ : _ : _ -> ""+              _ -> "0"+         in s1 ++ middle ++ s2++    osStr = case hostOS of+      Linux -> ["linux"]+      Windows -> ["mingw32"]+      OSX -> ["darwin"]+      FreeBSD -> ["freebsd"]+      OpenBSD -> ["openbsd"]+      NetBSD -> ["netbsd"]+      DragonFly -> ["dragonfly"]+      Solaris -> ["solaris2"]+      AIX -> ["aix"]+      HPUX -> ["hpux"]+      IRIX -> ["irix"]+      HaLVM -> []+      IOS -> ["ios"]+      Android -> ["android"]+      Ghcjs -> ["ghcjs"]+      Wasi -> ["wasi"]+      Hurd -> ["hurd"]+      Haiku -> ["haiku"]+      OtherOS _ -> []+    archStr = case hostArch of+      I386 -> ["i386"]+      X86_64 -> ["x86_64"]+      PPC -> ["powerpc"]+      PPC64 -> ["powerpc64"]+      PPC64LE -> ["powerpc64le"]+      Sparc -> ["sparc"]+      Sparc64 -> ["sparc64"]+      Arm -> ["arm"]+      AArch64 -> ["aarch64"]+      Mips -> ["mips"]+      SH -> []+      IA64 -> ["ia64"]+      S390 -> ["s390"]+      S390X -> ["s390x"]+      Alpha -> ["alpha"]+      Hppa -> ["hppa"]+      Rs6000 -> ["rs6000"]+      M68k -> ["m68k"]+      Vax -> ["vax"]+      RISCV64 -> ["riscv64"]+      LoongArch64 -> ["loongarch64"]+      JavaScript -> ["javascript"]+      Wasm32 -> ["wasm32"]+      OtherArch _ -> []++ppHappy :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppHappy _ lbi _ = pp{platformIndependent = True}+  where+    pp = standardPP lbi happyProgram (hcFlags hc)+    hc = compilerFlavor (compiler lbi)+    hcFlags GHC = ["-agc"]+    hcFlags GHCJS = ["-agc"]+    hcFlags _ = []++ppAlex :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppAlex _ lbi _ = pp{platformIndependent = True}+  where+    pp = standardPP lbi alexProgram (hcFlags hc)+    hc = compilerFlavor (compiler lbi)+    hcFlags GHC = ["-g"]+    hcFlags GHCJS = ["-g"]+    hcFlags _ = []++standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor+standardPP lbi prog args =+  PreProcessor+    { platformIndependent = False+    , ppOrdering = unsorted+    , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->+        runDbProgramCwd+          verbosity+          (mbWorkDirLBI lbi)+          prog+          (withPrograms lbi)+          (args ++ ["-o", outFile, inFile])+    }++-- | Convenience function; get the suffixes of these preprocessors.+ppSuffixes :: [PPSuffixHandler] -> [Suffix]+ppSuffixes = map fst++-- | Standard preprocessors: c2hs, hsc2hs, happy, alex and cpphs.+knownSuffixHandlers :: [PPSuffixHandler]+knownSuffixHandlers =+  [ (Suffix "chs", ppC2hs)+  , (Suffix "hsc", ppHsc2hs)+  , (Suffix "x", ppAlex)+  , (Suffix "y", ppHappy)+  , (Suffix "ly", ppHappy)+  , (Suffix "cpphs", ppCpp)+  ]++-- | Standard preprocessors with possible extra C sources: c2hs, hsc2hs.+knownExtrasHandlers :: [PreProcessorExtras]+knownExtrasHandlers = [ppC2hsExtras, ppHsc2hsExtras]++-- | Find any extra C sources generated by preprocessing that need to+-- be added to the component (addresses issue #238).+preprocessExtras+  :: Verbosity+  -> Component+  -> LocalBuildInfo+  -> IO [SymbolicPath Pkg File]+preprocessExtras verbosity comp lbi = case comp of+  CLib _ -> pp $ buildDir lbi+  (CExe exe@Executable{}) -> pp $ exeBuildDir lbi exe+  (CFLib flib@ForeignLib{}) -> pp $ flibBuildDir lbi flib+  CTest test ->+    case testInterface test of+      TestSuiteUnsupported tt ->+        dieWithException verbosity $ NoSupportPreProcessingTestExtras tt+      _ -> pp $ testBuildDir lbi test+  CBench bm ->+    case benchmarkInterface bm of+      BenchmarkUnsupported tt ->+        dieWithException verbosity $ NoSupportPreProcessingBenchmarkExtras tt+      _ -> pp $ benchmarkBuildDir lbi bm+  where+    pp :: SymbolicPath Pkg (Dir Build) -> IO [SymbolicPath Pkg File]+    pp builddir = do+      -- Use the build dir as a source dir.+      let dir :: SymbolicPath Pkg (Dir Source)+          dir = coerceSymbolicPath builddir+          mbWorkDir = mbWorkDirLBI lbi+      b <- doesDirectoryExist (interpretSymbolicPathLBI lbi dir)+      if b+        then do+          xs <- for knownExtrasHandlers $ withLexicalCallStack $ \f -> f mbWorkDir dir+          let not_subs =+                map (dir </>) $+                  filter (not_sub . getSymbolicPath) $+                    concat xs+          return not_subs+        else pure []+    -- TODO: This is a terrible hack to work around #3545 while we don't+    -- reorganize the directory layout.  Basically, for the main+    -- library, we might accidentally pick up autogenerated sources for+    -- our subcomponents, because they are all stored as subdirectories+    -- in dist/build.  This is a cheap and cheerful check to prevent+    -- this from happening.  It is not particularly correct; for example+    -- if a user has a test suite named foobar and puts their C file in+    -- foobar/foo.c, this test will incorrectly exclude it.  But I+    -- didn't want to break BC...+    not_sub p = and [not (pre `isPrefixOf` p) | pre <- component_dirs]+    component_dirs = component_names (localPkgDescr lbi)+    -- TODO: libify me+    component_names pkg_descr =+      fmap unUnqualComponentName $+        mapMaybe (libraryNameString . libName) (subLibraries pkg_descr)+          ++ map exeName (executables pkg_descr)+          ++ map testName (testSuites pkg_descr)+          ++ map benchmarkName (benchmarks pkg_descr)
+ src/Distribution/Simple/PreProcess/Types.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.PreProcess.Types+-- Copyright   :  (c) 2003-2005, Isaac Jones, Malcolm Wallace+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This defines a 'PreProcessor' abstraction which represents a pre-processor+-- that can transform one kind of file into another.+module Distribution.Simple.PreProcess.Types+  ( Suffix (..)+  , PreProcessor (..)+  , PreProcessCommand+  , builtinHaskellSuffixes+  , builtinHaskellBootSuffixes+  )+where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.ModuleName (ModuleName)+import Distribution.Pretty+import Distribution.Utils.Path+import Distribution.Verbosity+import qualified Text.PrettyPrint as Disp++-- | The interface to a preprocessor, which may be implemented using an+--  external program, but need not be.  The arguments are the name of+--  the input file, the name of the output file and a verbosity level.+--  Here is a simple example that merely prepends a comment to the given+--  source file:+--+--  > ppTestHandler :: PreProcessor+--  > ppTestHandler =+--  >   PreProcessor {+--  >     platformIndependent = True,+--  >     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 ()+--+--  We split the input and output file names into a base directory and the+--  rest of the file name. The input base dir is the path in the list of search+--  dirs that this file was found in. The output base dir is the build dir where+--  all the generated source files are put.+--+--  The reason for splitting it up this way is that some pre-processors don't+--  simply generate one output .hs file from one input file but have+--  dependencies on other generated files (notably c2hs, where building one+--  .hs file may require reading other .chi files, and then compiling the .hs+--  file may require reading a generated .h file). In these cases the generated+--  files need to embed relative path names to each other (eg the generated .hs+--  file mentions the .h file in the FFI imports). This path must be relative to+--  the base directory where the generated files are located, it cannot be+--  relative to the top level of the build tree because the compilers do not+--  look for .h files relative to there, ie we do not use \"-I .\", instead we+--  use \"-I dist\/build\" (or whatever dist dir has been set by the user)+--+--  Most pre-processors do not care of course, so mkSimplePreProcessor and+--  runSimplePreProcessor functions handle the simple case.+data PreProcessor = PreProcessor+  { -- Is the output of the pre-processor platform independent? eg happy output+    -- is portable haskell but c2hs's output is platform dependent.+    -- This matters since only platform independent generated code can be+    -- included into a source tarball.+    platformIndependent :: Bool+  , -- TODO: deal with pre-processors that have implementation dependent output+    --       eg alex and happy have --ghc flags. However we can't really include+    --       ghc-specific code into supposedly portable source tarballs.++    ppOrdering+      :: Verbosity+      -> [SymbolicPath Pkg (Dir Source)] -- Source directories+      -> [ModuleName] -- Module names+      -> IO [ModuleName] -- Sorted modules++  -- ^ This function can reorder /all/ modules, not just those that the+  -- require the preprocessor in question. As such, this function should be+  -- well-behaved and not reorder modules it doesn't have dominion over!+  --+  -- @since 3.8.1.0+  , runPreProcessor+      :: PreProcessCommand+  }++-- | A command to run a given preprocessor on a single source file.+--+-- The input and output file paths are passed in as arguments, as it is+-- the build system and not the package author which chooses the location of+-- source files.+type PreProcessCommand =+  (FilePath, FilePath)+  -- ^ Location of the source file relative to a base dir+  -> (FilePath, FilePath)+  -- ^ Output file name, relative to an output base dir+  -> Verbosity+  -> IO () -- Should exit if the preprocessor fails++-- | A suffix (or file extension).+--+-- Mostly used to decide which preprocessor to use, e.g. files with suffix @"y"@+-- are usually processed by the @"happy"@ build tool.+newtype Suffix = Suffix String+  deriving (Eq, Ord, Show, Generic, IsString)++instance Pretty Suffix where+  pretty (Suffix s) = Disp.text s++instance Binary Suffix+instance Structured Suffix++builtinHaskellSuffixes :: [Suffix]+builtinHaskellSuffixes = map Suffix ["hs", "lhs", "hsig", "lhsig"]++builtinHaskellBootSuffixes :: [Suffix]+builtinHaskellBootSuffixes = map Suffix ["hs-boot", "lhs-boot"]
src/Distribution/Simple/PreProcess/Unlit.hs view
@@ -1,4 +1,9 @@ -----------------------------------------------------------------------------++-- This version is interesting because instead of striping comment lines, it+-- turns them into "-- " style comments. This allows using haddock markup+-- in literate scripts without having to use "> --" prefix.+ -- | -- Module      :  Distribution.Simple.PreProcess.Unlit -- Copyright   :  ...@@ -8,73 +13,77 @@ -- -- Remove the \"literal\" markups from a Haskell source file, including -- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\"---- This version is interesting because instead of striping comment lines, it--- turns them into "-- " style comments. This allows using haddock markup--- in literate scripts without having to use "> --" prefix.--module Distribution.Simple.PreProcess.Unlit (unlit,plain) where--import Prelude ()-import Distribution.Compat.Prelude-import Distribution.Utils.Generic (safeTail, safeLast, safeInit)+module Distribution.Simple.PreProcess.Unlit (unlit, plain) where  import Data.List (mapAccumL)+import Distribution.Compat.Prelude+import Distribution.Simple.Errors+import Distribution.Utils.Generic (safeInit, safeLast, safeTail)+import Prelude () -data Classified = BirdTrack String | Blank String | Ordinary String-                | Line !Int String | CPP String-                | BeginCode | EndCode-                -- output only:-                | Error String | Comment String+data Classified+  = BirdTrack String+  | Blank String+  | Ordinary String+  | Line !Int String+  | CPP String+  | BeginCode+  | EndCode+  | -- output only:+    Error String+  | Comment String  -- | No unliteration. plain :: String -> String -> String plain _ hs = hs  classify :: String -> Classified-classify ('>':s) = BirdTrack s-classify ('#':s) = case tokens s of-                     (line:file@('"':_:_):_) | all isDigit line-                                            && safeLast file == Just '"'-                                -- this shouldn't fail as we tested for 'all isDigit'-                                -> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse-                     _          -> CPP s-  where tokens = unfoldr $ \str -> case lex str of-                                   (t@(_:_), str'):_ -> Just (t, str')-                                   _                 -> Nothing-classify ('\\':s)+classify ('>' : s) = BirdTrack s+classify ('#' : s) = case tokens s of+  (line : file@('"' : _ : _) : _)+    | all isDigit line+        && safeLast file == Just '"' ->+        -- this shouldn't fail as we tested for 'all isDigit'+        Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse+  _ -> CPP s+  where+    tokens = unfoldr $ \str -> case lex str of+      (t@(_ : _), str') : _ -> Just (t, str')+      _ -> Nothing+classify ('\\' : s)   | "begin{code}" `isPrefixOf` s = BeginCode-  | "end{code}"   `isPrefixOf` s = EndCode-classify s | all isSpace s       = Blank s-classify s                       = Ordinary s+  | "end{code}" `isPrefixOf` s = EndCode+classify s | all isSpace s = Blank s+classify s = Ordinary s  -- So the weird exception for comment indenting is to make things work with -- haddock, see classifyAndCheckForBirdTracks below. unclassify :: Bool -> Classified -> String-unclassify _     (BirdTrack s) = ' ':s-unclassify _     (Blank s)     = s-unclassify _     (Ordinary s)  = s-unclassify _     (Line n file) = "# " ++ show n ++ " " ++ show file-unclassify _     (CPP s)       = '#':s-unclassify True  (Comment "")  = "  --"-unclassify True  (Comment s)   = "  -- " ++ s-unclassify False (Comment "")  = "--"-unclassify False (Comment s)   = "-- " ++ s-unclassify _     _             = internalError+unclassify _ (BirdTrack s) = ' ' : s+unclassify _ (Blank s) = s+unclassify _ (Ordinary s) = s+unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file+unclassify _ (CPP s) = '#' : s+unclassify True (Comment "") = "  --"+unclassify True (Comment s) = "  -- " ++ s+unclassify False (Comment "") = "--"+unclassify False (Comment s) = "-- " ++ s+unclassify _ _ = internalError  -- | 'unlit' takes a filename (for error reports), and transforms the --   given string, to eliminate the literate comments from the program text.-unlit :: FilePath -> String -> Either String String+unlit :: FilePath -> String -> Either String CabalException unlit file input =-  let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks-                                   . inlines-                                   $ input-   in either (Left . unlines . map (unclassify usesBirdTracks))-              Right-    . checkErrors-    . reclassify-    $ classified-+  let (usesBirdTracks, classified) =+        classifyAndCheckForBirdTracks+          . inlines+          $ input+   in either+        (Left . unlines . map (unclassify usesBirdTracks))+        Right+        . checkErrors+        . reclassify+        $ classified   where     -- So haddock requires comments and code to align, since it treats comments     -- as following the layout rule. This is a pain for us since bird track@@ -94,16 +103,17 @@          in (seenBirdTrack || isBirdTrack classification, classification)      isBirdTrack (BirdTrack _) = True-    isBirdTrack _             = False+    isBirdTrack _ = False -    checkErrors ls = case [ e | Error e <- ls ] of-      []          -> Left  ls-      (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message)-        where (f, n) = errorPos file 1 ls-    errorPos f n []              = (f, n)-    errorPos f n (Error _:_)     = (f, n)-    errorPos _ _ (Line n' f':ls) = errorPos f' n' ls-    errorPos f n (_         :ls) = errorPos f  (n+1) ls+    checkErrors ls = case [e | Error e <- ls] of+      [] -> Left ls+      (message : _) -> Right (UnlitException (f ++ ":" ++ show n ++ ": " ++ message))+        where+          (f, n) = errorPos file 1 ls+    errorPos f n [] = (f, n)+    errorPos f n (Error _ : _) = (f, n)+    errorPos _ _ (Line n' f' : ls) = errorPos f' n' ls+    errorPos f n (_ : ls) = errorPos f (n + 1) ls  -- Here we model a state machine, with each state represented by -- a local function. We only have four states (well, five,@@ -117,51 +127,51 @@ reclassify :: [Classified] -> [Classified] reclassify = blank -- begin in blank state   where-    latex []               = []-    latex (EndCode    :ls) = Blank "" : comment ls-    latex (BeginCode  :_ ) = [Error "\\begin{code} in code section"]-    latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls-    latex (          l:ls) = l : latex ls+    latex [] = []+    latex (EndCode : ls) = Blank "" : comment ls+    latex (BeginCode : _) = [Error "\\begin{code} in code section"]+    latex (BirdTrack l : ls) = Ordinary ('>' : l) : latex ls+    latex (l : ls) = l : latex ls -    blank []               = []-    blank (EndCode    :_ ) = [Error "\\end{code} without \\begin{code}"]-    blank (BeginCode  :ls) = Blank ""    : latex ls-    blank (BirdTrack l:ls) = BirdTrack l : bird ls-    blank (Ordinary  l:ls) = Comment   l : comment ls-    blank (          l:ls) =           l : blank ls+    blank [] = []+    blank (EndCode : _) = [Error "\\end{code} without \\begin{code}"]+    blank (BeginCode : ls) = Blank "" : latex ls+    blank (BirdTrack l : ls) = BirdTrack l : bird ls+    blank (Ordinary l : ls) = Comment l : comment ls+    blank (l : ls) = l : blank ls -    bird []              = []-    bird (EndCode   :_ ) = [Error "\\end{code} without \\begin{code}"]-    bird (BeginCode :ls) = Blank "" : latex ls-    bird (Blank l   :ls) = Blank l  : blank ls-    bird (Ordinary _:_ ) = [Error "program line before comment line"]-    bird (         l:ls) = l : bird ls+    bird [] = []+    bird (EndCode : _) = [Error "\\end{code} without \\begin{code}"]+    bird (BeginCode : ls) = Blank "" : latex ls+    bird (Blank l : ls) = Blank l : blank ls+    bird (Ordinary _ : _) = [Error "program line before comment line"]+    bird (l : ls) = l : bird ls -    comment []               = []-    comment (EndCode    :_ ) = [Error "\\end{code} without \\begin{code}"]-    comment (BeginCode  :ls) = Blank "" : latex ls-    comment (CPP l      :ls) = CPP l : comment ls-    comment (BirdTrack _:_ ) = [Error "comment line before program line"]+    comment [] = []+    comment (EndCode : _) = [Error "\\end{code} without \\begin{code}"]+    comment (BeginCode : ls) = Blank "" : latex ls+    comment (CPP l : ls) = CPP l : comment ls+    comment (BirdTrack _ : _) = [Error "comment line before program line"]     -- a blank line and another ordinary line following a comment     -- will be treated as continuing the comment. Otherwise it's     -- then end of the comment, with a blank line.-    comment (Blank     l:ls@(Ordinary  _:_)) = Comment l : comment ls-    comment (Blank     l:ls) = Blank l   : blank ls-    comment (Line n f   :ls) = Line n f  : comment ls-    comment (Ordinary  l:ls) = Comment l : comment ls-    comment (Comment   _: _) = internalError-    comment (Error     _: _) = internalError+    comment (Blank l : ls@(Ordinary _ : _)) = Comment l : comment ls+    comment (Blank l : ls) = Blank l : blank ls+    comment (Line n f : ls) = Line n f : comment ls+    comment (Ordinary l : ls) = Comment l : comment ls+    comment (Comment _ : _) = internalError+    comment (Error _ : _) = internalError  -- Re-implementation of 'lines', for better efficiency (but decreased laziness). -- Also, importantly, accepts non-standard DOS and Mac line ending characters. inlines :: String -> [String] inlines xs = lines' xs id   where-  lines' []             acc = [acc []]-  lines' ('\^M':'\n':s) acc = acc [] : lines' s id    -- DOS-  lines' ('\^M':s)      acc = acc [] : lines' s id    -- MacOS-  lines' ('\n':s)       acc = acc [] : lines' s id    -- Unix-  lines' (c:s)          acc = lines' s (acc . (c:))+    lines' [] acc = [acc []]+    lines' ('\^M' : '\n' : s) acc = acc [] : lines' s id -- DOS+    lines' ('\^M' : s) acc = acc [] : lines' s id -- MacOS+    lines' ('\n' : s) acc = acc [] : lines' s id -- Unix+    lines' (c : s) acc = lines' s (acc . (c :))  internalError :: a internalError = error "unlit: internal error"
src/Distribution/Simple/Program.hs view
@@ -1,7 +1,16 @@+{- FUTUREWORK:+ -+ - Currently the logic in this module is not tested.+ -+ - Ideally, a set of unit tests that check whether certain+ - flags trigger recompilation should be added.+ - -}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Program -- Copyright   :  Isaac Jones 2006, Duncan Coutts 2007-2009@@ -34,150 +43,209 @@ -- hookedPrograms in 'Distribution.Simple.UserHooks'.  This gives a -- hook user the ability to get the above flags and such so that they -- don't have to write all the PATH logic inside Setup.lhs.--module Distribution.Simple.Program (-    -- * Program and functions for constructing them-      Program(..)-    , ProgramSearchPath-    , ProgramSearchPathEntry(..)-    , simpleProgram-    , findProgramOnSearchPath-    , defaultProgramSearchPath-    , findProgramVersion+module Distribution.Simple.Program+  ( -- * Program and functions for constructing them+    Program (..)+  , ProgramSearchPath+  , ProgramSearchPathEntry (..)+  , simpleProgram+  , findProgramOnSearchPath+  , defaultProgramSearchPath+  , findProgramVersion      -- * Configured program and related functions-    , ConfiguredProgram(..)-    , programPath-    , ProgArg-    , ProgramLocation(..)-    , runProgram-    , getProgramOutput-    , suppressOverrideArgs+  , ConfiguredProgram (..)+  , programPath+  , ProgArg+  , ProgramLocation (..)+  , runProgram+  , runProgramCwd+  , getProgramOutput+  , suppressOverrideArgs      -- * Program invocations-    , ProgramInvocation(..)-    , emptyProgramInvocation-    , simpleProgramInvocation-    , programInvocation-    , runProgramInvocation-    , getProgramInvocationOutput-    , getProgramInvocationLBS+  , ProgramInvocation (..)+  , emptyProgramInvocation+  , simpleProgramInvocation+  , programInvocation+  , runProgramInvocation+  , getProgramInvocationOutput+  , getProgramInvocationLBS      -- * The collection of unconfigured and configured programs-    , builtinPrograms+  , builtinPrograms      -- * The collection of configured programs we can run-    , ProgramDb-    , defaultProgramDb-    , emptyProgramDb-    , restoreProgramDb-    , addKnownProgram-    , addKnownPrograms-    , lookupKnownProgram-    , knownPrograms-    , getProgramSearchPath-    , setProgramSearchPath-    , userSpecifyPath-    , userSpecifyPaths-    , userMaybeSpecifyPath-    , userSpecifyArgs-    , userSpecifyArgss-    , userSpecifiedArgs-    , lookupProgram-    , lookupProgramVersion-    , updateProgram-    , configureProgram-    , configureAllKnownPrograms-    , reconfigurePrograms-    , requireProgram-    , requireProgramVersion-    , needProgram-    , runDbProgram-    , getDbProgramOutput+  , ProgramDb+  , defaultProgramDb+  , emptyProgramDb+  , restoreProgramDb+  , addKnownProgram+  , addKnownPrograms+  , lookupKnownProgram+  , knownPrograms+  , getProgramSearchPath+  , setProgramSearchPath+  , userSpecifyPath+  , userSpecifyPaths+  , userMaybeSpecifyPath+  , userSpecifyArgs+  , userSpecifyArgss+  , userSpecifiedArgs+  , lookupProgram+  , lookupProgramVersion+  , updateProgram+  , configureProgram+  , configureAllKnownPrograms+  , reconfigurePrograms+  , requireProgram+  , requireProgramVersion+  , needProgram+  , runDbProgram+  , runDbProgramCwd+  , getDbProgramOutput+  , getDbProgramOutputCwd      -- * Programs that Cabal knows about-    , ghcProgram-    , ghcPkgProgram-    , ghcjsProgram-    , ghcjsPkgProgram-    , hmakeProgram-    , jhcProgram-    , uhcProgram-    , gccProgram-    , arProgram-    , stripProgram-    , happyProgram-    , alexProgram-    , hsc2hsProgram-    , c2hsProgram-    , cpphsProgram-    , hscolourProgram-    , doctestProgram-    , haddockProgram-    , greencardProgram-    , ldProgram-    , tarProgram-    , cppProgram-    , pkgConfigProgram-    , hpcProgram-    ) where+  , ghcProgram+  , ghcPkgProgram+  , ghcjsProgram+  , ghcjsPkgProgram+  , jhcProgram+  , uhcProgram+  , gccProgram+  , gppProgram+  , arProgram+  , stripProgram+  , happyProgram+  , alexProgram+  , hsc2hsProgram+  , c2hsProgram+  , cpphsProgram+  , hscolourProgram+  , doctestProgram+  , haddockProgram+  , ldProgram+  , tarProgram+  , cppProgram+  , pkgConfigProgram+  , hpcProgram+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Simple.Program.Types-import Distribution.Simple.Program.Run-import Distribution.Simple.Program.Db+import Distribution.Simple.Errors import Distribution.Simple.Program.Builtin+import Distribution.Simple.Program.Db import Distribution.Simple.Program.Find+import Distribution.Simple.Program.Run+import Distribution.Simple.Program.Types import Distribution.Simple.Utils+import Distribution.Utils.Path import Distribution.Verbosity  -- | Runs the given configured program.-runProgram :: Verbosity          -- ^Verbosity-           -> ConfiguredProgram  -- ^The program to run-           -> [ProgArg]          -- ^Any /extra/ arguments to add-           -> IO ()+runProgram+  :: Verbosity+  -- ^ Verbosity+  -> ConfiguredProgram+  -- ^ The program to run+  -> [ProgArg]+  -- ^ Any /extra/ arguments to add+  -> IO () runProgram verbosity prog args =   runProgramInvocation verbosity (programInvocation prog args) +-- | Runs the given configured program.+runProgramCwd+  :: Verbosity+  -- ^ Verbosity+  -> Maybe (SymbolicPath CWD (Dir to))+  -- ^ Working directory+  -> ConfiguredProgram+  -- ^ The program to run+  -> [ProgArg]+  -- ^ Any /extra/ arguments to add+  -> IO ()+runProgramCwd verbosity mbWorkDir prog args =+  runProgramInvocation verbosity (programInvocationCwd mbWorkDir prog args)  -- | Runs the given configured program and gets the output.----getProgramOutput :: Verbosity          -- ^Verbosity-                 -> ConfiguredProgram  -- ^The program to run-                 -> [ProgArg]          -- ^Any /extra/ arguments to add-                 -> IO String+getProgramOutput+  :: Verbosity+  -- ^ Verbosity+  -> ConfiguredProgram+  -- ^ The program to run+  -> [ProgArg]+  -- ^ Any /extra/ arguments to add+  -> IO String getProgramOutput verbosity prog args =   getProgramInvocationOutput verbosity (programInvocation prog args) +-- | Looks up the given program in the program database and runs it.+runDbProgram+  :: Verbosity+  -- ^ verbosity+  -> Program+  -- ^ The program to run+  -> ProgramDb+  -- ^ look up the program here+  -> [ProgArg]+  -- ^ Any /extra/ arguments to add+  -> IO ()+runDbProgram verbosity prog progDb args =+  runDbProgramCwd verbosity Nothing prog progDb args  -- | Looks up the given program in the program database and runs it.----runDbProgram :: Verbosity  -- ^verbosity-             -> Program    -- ^The program to run-             -> ProgramDb  -- ^look up the program here-             -> [ProgArg]  -- ^Any /extra/ arguments to add-             -> IO ()-runDbProgram verbosity prog programDb args =+runDbProgramCwd+  :: Verbosity+  -- ^ verbosity+  -> Maybe (SymbolicPath CWD (Dir to))+  -- ^ working directory+  -> Program+  -- ^ The program to run+  -> ProgramDb+  -- ^ look up the program here+  -> [ProgArg]+  -- ^ Any /extra/ arguments to add+  -> IO ()+runDbProgramCwd verbosity mbWorkDir prog programDb args =   case lookupProgram prog programDb of-    Nothing             -> die' verbosity notFound-    Just configuredProg -> runProgram verbosity configuredProg args- where-   notFound = "The program '" ++ programName prog-           ++ "' is required but it could not be found"+    Nothing ->+      dieWithException verbosity $ ProgramNotFound (programName prog)+    Just configuredProg -> runProgramCwd verbosity mbWorkDir configuredProg args  -- | Looks up the given program in the program database and runs it.----getDbProgramOutput :: Verbosity  -- ^verbosity-                   -> Program    -- ^The program to run-                   -> ProgramDb  -- ^look up the program here-                   -> [ProgArg]  -- ^Any /extra/ arguments to add-                   -> IO String-getDbProgramOutput verbosity prog programDb args =+getDbProgramOutput+  :: Verbosity+  -- ^ verbosity+  -> Program+  -- ^ The program to run+  -> ProgramDb+  -- ^ look up the program here+  -> [ProgArg]+  -- ^ Any /extra/ arguments to add+  -> IO String+getDbProgramOutput verb prog progDb args =+  getDbProgramOutputCwd verb Nothing prog progDb args++-- | Looks up the given program in the program database and runs it.+getDbProgramOutputCwd+  :: Verbosity+  -- ^ verbosity+  -> Maybe (SymbolicPath CWD (Dir to))+  -- ^ working directory+  -> Program+  -- ^ The program to run+  -> ProgramDb+  -- ^ look up the program here+  -> [ProgArg]+  -- ^ Any /extra/ arguments to add+  -> IO String+getDbProgramOutputCwd verbosity mbWorkDir prog programDb args =   case lookupProgram prog programDb of-    Nothing             -> die' verbosity notFound-    Just configuredProg -> getProgramOutput verbosity configuredProg args- where-   notFound = "The program '" ++ programName prog-           ++ "' is required but it could not be found"+    Nothing -> dieWithException verbosity $ ProgramNotFound (programName prog)+    Just configuredProg ->+      getProgramInvocationOutput verbosity $+        programInvocationCwd mbWorkDir configuredProg args
src/Distribution/Simple/Program/Ar.hs view
@@ -1,9 +1,11 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE NondecreasingIndentation #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Program.Ar -- Copyright   :  Duncan Coutts 2009@@ -12,115 +14,163 @@ -- Portability :  portable -- -- This module provides an library interface to the @ar@ program.--module Distribution.Simple.Program.Ar (-    createArLibArchive,-    multiStageProgramInvocation+module Distribution.Simple.Program.Ar+  ( createArLibArchive+  , multiStageProgramInvocation   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Distribution.Compat.CopyFile (filesEqual)-import Distribution.Simple.Compiler (arResponseFilesSupported)-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))+import Distribution.Simple.Compiler (arDashLSupported, arResponseFilesSupported)+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI) import Distribution.Simple.Program-         ( ProgramInvocation, arProgram, requireProgram )+  ( ProgramInvocation+  , arProgram+  , requireProgram+  ) import Distribution.Simple.Program.ResponseFile-         ( withResponseFile )+  ( withResponseFile+  ) import Distribution.Simple.Program.Run-         ( programInvocation, multiStageProgramInvocation-         , runProgramInvocation )-import Distribution.Simple.Setup-         ( fromFlagOrDefault, configUseResponseFiles )+  ( multiStageProgramInvocation+  , programInvocationCwd+  , runProgramInvocation+  )+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Config+  ( configUseResponseFiles+  ) import Distribution.Simple.Utils-         ( defaultTempFileOptions, dieWithLocation', withTempDirectory )+  ( defaultTempFileOptions+  , dieWithLocation'+  , withTempDirectoryCwd+  ) import Distribution.System-         ( Arch(..), OS(..), Platform(..) )+  ( Arch (..)+  , OS (..)+  , Platform (..)+  )+import Distribution.Utils.Path import Distribution.Verbosity-         ( Verbosity, deafening, verbose )+  ( Verbosity+  , deafening+  , verbose+  )+ import System.Directory (doesFileExist, renameFile)-import System.FilePath ((</>), splitFileName)+import System.FilePath (splitFileName) import System.IO-         ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek)-         , hFileSize, hSeek, withBinaryFile )+  ( Handle+  , IOMode (ReadWriteMode)+  , SeekMode (AbsoluteSeek)+  , hFileSize+  , hSeek+  , withBinaryFile+  )  -- | Call @ar@ to create a library archive from a bunch of object files.----createArLibArchive :: Verbosity -> LocalBuildInfo-                   -> FilePath -> [FilePath] -> IO ()+createArLibArchive+  :: Verbosity+  -> LocalBuildInfo+  -> SymbolicPath Pkg File+  -> [SymbolicPath Pkg File]+  -> IO () createArLibArchive verbosity lbi targetPath files = do-  (ar, _) <- requireProgram verbosity arProgram progDb--  let (targetDir, targetName) = splitFileName targetPath-  withTempDirectory verbosity targetDir "objs" $ \ tmpDir -> do-  let tmpPath = tmpDir </> targetName+  (arProg, _) <- requireProgram verbosity arProgram progDb -  -- The args to use with "ar" are actually rather subtle and system-dependent.-  -- In particular we have the following issues:-  ---  --  -- On OS X, "ar q" does not make an archive index. Archives with no-  --     index cannot be used.-  ---  --  -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us-  --     do that. We have duplicates because of modules like "A.M" and "B.M"-  --     both make an object file "M.o" and ar does not consider the directory.-  ---  -- Our solution is to use "ar r" in the simple case when one call is enough.-  -- When we need to call ar multiple times we use "ar q" and for the last-  -- call on OSX we use "ar qs" so that it'll make the index.+  let (targetDir0, targetName0) = splitFileName $ getSymbolicPath targetPath+      targetDir = makeSymbolicPath targetDir0+      targetName = makeRelativePathEx targetName0+      mbWorkDir = mbWorkDirLBI lbi+      -- See Note [Symbolic paths] in Distribution.Utils.Path+      i = interpretSymbolicPath mbWorkDir+      u :: SymbolicPath Pkg to -> FilePath+      u = interpretSymbolicPathCWD+  withTempDirectoryCwd verbosity mbWorkDir targetDir "objs" $ \tmpDir -> do+    let tmpPath = tmpDir </> targetName -  let simpleArgs  = case hostOS of-             OSX -> ["-r", "-s"]-             _   -> ["-r"]+    -- The args to use with "ar" are actually rather subtle and system-dependent.+    -- In particular we have the following issues:+    --+    --  -- On OS X, "ar q" does not make an archive index. Archives with no+    --     index cannot be used.+    --+    --  -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us+    --     do that. We have duplicates because of modules like "A.M" and "B.M"+    --     both make an object file "M.o" and ar does not consider the directory.+    --+    --  -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier+    --     in "q" mode which compels the archiver to add the members of an input+    --     archive to the output, rather than the archive itself. This is+    --     necessary as GHC may produce .o files that are actually archives. See+    --     https://gitlab.haskell.org/ghc/ghc/-/issues/21068.+    --+    -- Our solution is to use "ar r" in the simple case when one call is enough.+    -- When we need to call ar multiple times we use "ar q" and for the last+    -- call on OSX we use "ar qs" so that it'll make the index. -      initialArgs = ["-q"]-      finalArgs   = case hostOS of-             OSX -> ["-q", "-s"]-             _   -> ["-q"]+    let simpleArgs, initialArgs, finalArgs :: [String]+        simpleArgs = case hostOS of+          OSX -> ["-r", "-s"]+          _ | dashLSupported -> ["-qL"]+          _ -> ["-r"] -      extraArgs   = verbosityOpts verbosity ++ [tmpPath]+        initialArgs = ["-q"]+        finalArgs = case hostOS of+          OSX -> ["-q", "-s"]+          _ | dashLSupported -> ["-qL"]+          _ -> ["-q"] -      simple  = programInvocation ar (simpleArgs  ++ extraArgs)-      initial = programInvocation ar (initialArgs ++ extraArgs)-      middle  = initial-      final   = programInvocation ar (finalArgs   ++ extraArgs)+        extraArgs = verbosityOpts verbosity ++ [u tmpPath] -      oldVersionManualOverride =-        fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi-      responseArgumentsNotSupported   =-        not (arResponseFilesSupported (compiler lbi))+        ar = programInvocationCwd mbWorkDir arProg+        simple = ar (simpleArgs ++ extraArgs)+        initial = ar (initialArgs ++ extraArgs)+        middle = initial+        final = ar (finalArgs ++ extraArgs) -      invokeWithResponesFile :: FilePath -> ProgramInvocation-      invokeWithResponesFile atFile =-        programInvocation ar $-        simpleArgs ++ extraArgs ++ ['@' : atFile]+        oldVersionManualOverride =+          fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi+        responseArgumentsNotSupported =+          not (arResponseFilesSupported (compiler lbi))+        dashLSupported =+          arDashLSupported (compiler lbi) -  if oldVersionManualOverride || responseArgumentsNotSupported-    then-      sequence_-        [ runProgramInvocation verbosity inv-        | inv <- multiStageProgramInvocation-                   simple (initial, middle, final) files ]-    else-      withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $-        \path -> runProgramInvocation verbosity $ invokeWithResponesFile path+        invokeWithResponseFile :: FilePath -> ProgramInvocation+        invokeWithResponseFile atFile =+          (ar $ simpleArgs ++ extraArgs ++ ['@' : atFile]) -  unless (hostArch == Arm -- See #1537-          || hostOS == AIX) $ -- AIX uses its own "ar" format variant-    wipeMetadata verbosity tmpPath-  equal <- filesEqual tmpPath targetPath-  unless equal $ renameFile tmpPath targetPath+    if oldVersionManualOverride || responseArgumentsNotSupported+      then+        sequence_+          [ runProgramInvocation verbosity inv+          | inv <-+              multiStageProgramInvocation+                simple+                (initial, middle, final)+                (map getSymbolicPath files)+          ]+      else withResponseFile verbosity defaultTempFileOptions "ar.rsp" Nothing (map getSymbolicPath files) $+        \path -> runProgramInvocation verbosity $ invokeWithResponseFile path +    unless+      ( hostArch == Arm -- See #1537+          || hostOS == AIX+      )+      $ wipeMetadata verbosity (i tmpPath) -- AIX uses its own "ar" format variant+    equal <- filesEqual (i tmpPath) (i targetPath)+    unless equal $ renameFile (i tmpPath) (i targetPath)   where     progDb = withPrograms lbi     Platform hostArch hostOS = hostPlatform lbi     verbosityOpts v       | v >= deafening = ["-v"]-      | v >= verbose   = []-      | otherwise      = ["-c"] -- Do not warn if library had to be created.+      | v >= verbose = []+      | otherwise = ["-c"] -- Do not warn if library had to be created.  -- | @ar@ by default includes various metadata for each object file in their -- respective headers, so the output can differ for the same inputs, making@@ -130,17 +180,18 @@ -- rather harder than just re-implementing this feature. wipeMetadata :: Verbosity -> FilePath -> IO () wipeMetadata verbosity path = do-    -- Check for existence first (ReadWriteMode would create one otherwise)-    exists <- doesFileExist path-    unless exists $ wipeError "Temporary file disappeared"-    withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h-+  -- Check for existence first (ReadWriteMode would create one otherwise)+  exists <- doesFileExist path+  unless exists $ wipeError "Temporary file disappeared"+  withBinaryFile path ReadWriteMode $ \h -> hFileSize h >>= wipeArchive h   where-    wipeError msg = dieWithLocation' verbosity path Nothing $+    wipeError msg =+      dieWithLocation' verbosity path Nothing $         "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg     archLF = "!<arch>\x0a" -- global magic, 8 bytes     x60LF = "\x60\x0a" -- header magic, 2 bytes-    metadata = BS.concat+    metadata =+      BS.concat         [ "0           " -- mtime, 12 bytes         , "0     " -- UID, 6 bytes         , "0     " -- GID, 6 bytes@@ -152,40 +203,41 @@     -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details     wipeArchive :: Handle -> Integer -> IO ()     wipeArchive h archiveSize = do-        global <- BS.hGet h (BS.length archLF)-        unless (global == archLF) $ wipeError "Bad global header"-        wipeHeader (toInteger $ BS.length archLF)-+      global <- BS.hGet h (BS.length archLF)+      unless (global == archLF) $ wipeError "Bad global header"+      wipeHeader (toInteger $ BS.length archLF)       where         wipeHeader :: Integer -> IO ()         wipeHeader offset = case compare offset archiveSize of-            EQ -> return ()-            GT -> wipeError (atOffset "Archive truncated")-            LT -> do-                header <- BS.hGet h headerSize-                unless (BS.length header == headerSize) $-                    wipeError (atOffset "Short header")-                let magic = BS.drop 58 header-                unless (magic == x60LF) . wipeError . atOffset $-                    "Bad magic " ++ show magic ++ " in header"--                let name = BS.take 16 header-                let size = BS.take 10 $ BS.drop 48 header-                objSize <- case reads (BS8.unpack size) of-                    [(n, s)] | all isSpace s -> return n-                    _ -> wipeError (atOffset "Bad file size in header")+          EQ -> return ()+          GT -> wipeError (atOffset "Archive truncated")+          LT -> do+            header <- BS.hGet h headerSize+            unless (BS.length header == headerSize) $+              wipeError (atOffset "Short header")+            let magic = BS.drop 58 header+            unless (magic == x60LF) . wipeError . atOffset $+              "Bad magic " ++ show magic ++ " in header" -                let replacement = BS.concat [ name, metadata, size, magic ]-                unless (BS.length replacement == headerSize) $-                    wipeError (atOffset "Something has gone terribly wrong")-                hSeek h AbsoluteSeek offset-                BS.hPut h replacement+            let name = BS.take 16 header+            let size = BS.take 10 $ BS.drop 48 header+            objSize <- case reads (BS8.unpack size) of+              [(n, s)] | all isSpace s -> return n+              _ -> wipeError (atOffset "Bad file size in header") -                let nextHeader = offset + toInteger headerSize +-                        -- Odd objects are padded with an extra '\x0a'-                        if odd objSize then objSize + 1 else objSize-                hSeek h AbsoluteSeek nextHeader-                wipeHeader nextHeader+            let replacement = BS.concat [name, metadata, size, magic]+            unless (BS.length replacement == headerSize) $+              wipeError (atOffset "Something has gone terribly wrong")+            hSeek h AbsoluteSeek offset+            BS.hPut h replacement +            let nextHeader =+                  offset+                    + toInteger headerSize+                    ++                    -- Odd objects are padded with an extra '\x0a'+                    if odd objSize then objSize + 1 else objSize+            hSeek h AbsoluteSeek nextHeader+            wipeHeader nextHeader           where             atOffset msg = msg ++ " at offset " ++ show offset
src/Distribution/Simple/Program/Builtin.hs view
@@ -1,4 +1,5 @@ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Program.Builtin -- Copyright   :  Isaac Jones 2006, Duncan Coutts 2007-2009@@ -9,47 +10,42 @@ -- The module defines all the known built-in 'Program's. -- -- Where possible we try to find their version numbers.----module Distribution.Simple.Program.Builtin (--    -- * The collection of unconfigured and configured programs-    builtinPrograms,+module Distribution.Simple.Program.Builtin+  ( -- * The collection of unconfigured and configured programs+    builtinPrograms      -- * Programs that Cabal knows about-    ghcProgram,-    ghcPkgProgram,-    runghcProgram,-    ghcjsProgram,-    ghcjsPkgProgram,-    hmakeProgram,-    jhcProgram,-    haskellSuiteProgram,-    haskellSuitePkgProgram,-    uhcProgram,-    gccProgram,-    arProgram,-    stripProgram,-    happyProgram,-    alexProgram,-    hsc2hsProgram,-    c2hsProgram,-    cpphsProgram,-    hscolourProgram,-    doctestProgram,-    haddockProgram,-    greencardProgram,-    ldProgram,-    tarProgram,-    cppProgram,-    pkgConfigProgram,-    hpcProgram,+  , ghcProgram+  , ghcPkgProgram+  , runghcProgram+  , ghcjsProgram+  , ghcjsPkgProgram+  , jhcProgram+  , uhcProgram+  , gccProgram+  , gppProgram+  , arProgram+  , stripProgram+  , happyProgram+  , alexProgram+  , hsc2hsProgram+  , c2hsProgram+  , cpphsProgram+  , hscolourProgram+  , doctestProgram+  , haddockProgram+  , ldProgram+  , tarProgram+  , cppProgram+  , pkgConfigProgram+  , hpcProgram   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Simple.Program.GHC import Distribution.Simple.Program.Find+import Distribution.Simple.Program.GHC import Distribution.Simple.Program.Internal import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types@@ -60,289 +56,331 @@ import qualified Data.Map as Map  -- ------------------------------------------------------------+ -- * Known programs+ -- ------------------------------------------------------------  -- | The default list of programs. -- These programs are typically used internally to Cabal. builtinPrograms :: [Program] builtinPrograms =-    [-    -- compilers and related progs-      ghcProgram-    , runghcProgram-    , ghcPkgProgram-    , ghcjsProgram-    , ghcjsPkgProgram-    , haskellSuiteProgram-    , haskellSuitePkgProgram-    , hmakeProgram-    , jhcProgram-    , uhcProgram-    , hpcProgram-    -- preprocessors-    , hscolourProgram-    , doctestProgram-    , haddockProgram-    , happyProgram-    , alexProgram-    , hsc2hsProgram-    , c2hsProgram-    , cpphsProgram-    , greencardProgram-    -- platform toolchain-    , gccProgram-    , arProgram-    , stripProgram-    , ldProgram-    , tarProgram-    -- configuration tools-    , pkgConfigProgram-    ]+  [ -- compilers and related progs+    ghcProgram+  , runghcProgram+  , ghcPkgProgram+  , ghcjsProgram+  , ghcjsPkgProgram+  , jhcProgram+  , uhcProgram+  , hpcProgram+  , -- preprocessors+    hscolourProgram+  , doctestProgram+  , haddockProgram+  , happyProgram+  , alexProgram+  , hsc2hsProgram+  , c2hsProgram+  , cpphsProgram+  , -- platform toolchain+    gccProgram+  , arProgram+  , stripProgram+  , ldProgram+  , tarProgram+  , -- configuration tools+    pkgConfigProgram+  ]  ghcProgram :: Program-ghcProgram = (simpleProgram "ghc") {-    programFindVersion = findProgramVersion "--numeric-version" id,+ghcProgram =+  (simpleProgram "ghc")+    { programFindVersion = findProgramVersion "--numeric-version" id+    , programPostConf = ghcPostConf+    , programNormaliseArgs = normaliseGhcArgs+    }+  where+    ghcPostConf _verbosity ghcProg = do+      let setLanguageEnv prog =+            prog+              { programOverrideEnv =+                  ("LANGUAGE", Just "en")+                    : programOverrideEnv ghcProg+              } -    -- 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),+          ignorePackageEnv prog = prog{programDefaultArgs = "-package-env=-" : programDefaultArgs prog} -    programNormaliseArgs = normaliseGhcArgs-  }+          -- 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]) +          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 environmnet+              -- files. See #10759+              applyWhen (withinRange v canIgnorePackageEnv) ignorePackageEnv+              -- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/8825+              -- (spurious warning on non-english locales)+              $+                applyWhen (withinRange v affectedVersionRange) setLanguageEnv $+                  ghcProg+          )+          (programVersion ghcProg)+ runghcProgram :: Program-runghcProgram = (simpleProgram "runghc") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      case words str of-        -- "runghc 7.10.3"-        (_:ver:_) -> ver-        _ -> ""-  }+runghcProgram =+  (simpleProgram "runghc")+    { programFindVersion = findProgramVersion "--version" $ \str ->+        case words str of+          -- "runghc 7.10.3"+          (_ : ver : _) -> ver+          _ -> ""+    }  ghcPkgProgram :: Program-ghcPkgProgram = (simpleProgram "ghc-pkg") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      -- Invoking "ghc-pkg --version" gives a string like-      -- "GHC package manager version 6.4.1"-      case words str of-        (_:_:_:_:ver:_) -> ver-        _               -> ""-  }+ghcPkgProgram =+  (simpleProgram "ghc-pkg")+    { programFindVersion = findProgramVersion "--version" $ \str ->+        -- Invoking "ghc-pkg --version" gives a string like+        -- "GHC package manager version 6.4.1"+        case words str of+          (_ : _ : _ : _ : ver : _) -> ver+          _ -> ""+    }  ghcjsProgram :: Program-ghcjsProgram = (simpleProgram "ghcjs") {-    programFindVersion = findProgramVersion "--numeric-ghcjs-version" id-  }+ghcjsProgram =+  (simpleProgram "ghcjs")+    { programFindVersion = findProgramVersion "--numeric-ghcjs-version" id+    }  -- note: version is the version number of the GHC version that ghcjs-pkg was built with ghcjsPkgProgram :: Program-ghcjsPkgProgram = (simpleProgram "ghcjs-pkg") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      -- Invoking "ghcjs-pkg --version" gives a string like-      -- "GHCJS package manager version 6.4.1"-      case words str of-        (_:_:_:_:ver:_) -> ver-        _               -> ""-  }--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-        _         -> ""-  }+ghcjsPkgProgram =+  (simpleProgram "ghcjs-pkg")+    { programFindVersion = findProgramVersion "--version" $ \str ->+        -- Invoking "ghcjs-pkg --version" gives a string like+        -- "GHCJS package manager version 6.4.1"+        case words str of+          (_ : _ : _ : _ : ver : _) -> ver+          _ -> ""+    }  jhcProgram :: Program-jhcProgram = (simpleProgram "jhc") {-    programFindVersion = findProgramVersion "--version" $ \str ->-    -- invoking "jhc --version" gives a string like-    -- "jhc 0.3.20080208 (wubgipkamcep-2)-    -- compiled by ghc-6.8 on a x86_64 running linux"-      case words str of-        (_:ver:_) -> ver-        _         -> ""-  }+jhcProgram =+  (simpleProgram "jhc")+    { programFindVersion = findProgramVersion "--version" $ \str ->+        -- invoking "jhc --version" gives a string like+        -- "jhc 0.3.20080208 (wubgipkamcep-2)+        -- compiled by ghc-6.8 on a x86_64 running linux"+        case words str of+          (_ : ver : _) -> ver+          _ -> ""+    }  uhcProgram :: Program-uhcProgram = (simpleProgram "uhc") {-    programFindVersion = findProgramVersion "--version-dotted" id-  }+uhcProgram =+  (simpleProgram "uhc")+    { programFindVersion = findProgramVersion "--version-dotted" id+    }  hpcProgram :: Program-hpcProgram = (simpleProgram "hpc")-    {-        programFindVersion = findProgramVersion "version" $ \str ->-            case words str of-                (_ : _ : _ : ver : _) -> ver-                _ -> ""+hpcProgram =+  (simpleProgram "hpc")+    { programFindVersion = findProgramVersion "version" $ \str ->+        case words str of+          (_ : _ : _ : ver : _) -> ver+          _ -> ""     } --- This represents a haskell-suite compiler. Of course, the compiler--- itself probably is not called "haskell-suite", so this is not a real--- program. (But we don't know statically the name of the actual compiler,--- so this is the best we can do.)------ Having this Program value serves two purposes:------ 1. We can accept options for the compiler in the form of------   --haskell-suite-option(s)=...------ 2. We can find a program later using this static id (with--- requireProgram).------ The path to the real compiler is found and recorded in the ProgramDb--- during the configure phase.-haskellSuiteProgram :: Program-haskellSuiteProgram = (simpleProgram "haskell-suite") {-    -- pretend that the program exists, otherwise it won't be in the-    -- "configured" state-    programFindLocation = \_verbosity _searchPath ->-      return $ Just ("haskell-suite-dummy-location", [])-  }---- This represent a haskell-suite package manager. See the comments for--- haskellSuiteProgram.-haskellSuitePkgProgram :: Program-haskellSuitePkgProgram = (simpleProgram "haskell-suite-pkg") {-    programFindLocation = \_verbosity _searchPath ->-      return $ Just ("haskell-suite-pkg-dummy-location", [])-  }-- happyProgram :: Program-happyProgram = (simpleProgram "happy") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      -- Invoking "happy --version" gives a string like-      -- "Happy Version 1.16 Copyright (c) ...."-      case words str of-        (_:_:ver:_) -> ver-        _           -> ""-  }+happyProgram =+  (simpleProgram "happy")+    { programFindVersion = findProgramVersion "--version" $ \str ->+        -- Invoking "happy --version" gives a string like+        -- "Happy Version 1.16 Copyright (c) ...."+        case words str of+          (_ : _ : ver : _) -> ver+          _ -> ""+    }  alexProgram :: Program-alexProgram = (simpleProgram "alex") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      -- Invoking "alex --version" gives a string like-      -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow"-      case words str of-        (_:_:ver:_) -> takeWhile (\x -> isDigit x || x == '.') ver-        _           -> ""-  }+alexProgram =+  (simpleProgram "alex")+    { programFindVersion = findProgramVersion "--version" $ \str ->+        -- Invoking "alex --version" gives a string like+        -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow"+        case words str of+          (_ : _ : ver : _) -> takeWhile (\x -> isDigit x || x == '.') ver+          _ -> ""+    }  gccProgram :: Program-gccProgram = (simpleProgram "gcc") {-    programFindVersion = findProgramVersion "-dumpversion" id-  }+gccProgram =+  (simpleProgram "gcc")+    { programFindVersion = findProgramVersion "-dumpversion" id+    } +gppProgram :: Program+gppProgram =+  (simpleProgram "gpp")+    { programFindVersion = findProgramVersion "-dumpversion" id+    , programFindLocation = \v p -> findProgramOnSearchPath v p "g++"+    }+ arProgram :: Program arProgram = simpleProgram "ar"  stripProgram :: Program-stripProgram = (simpleProgram "strip") {-    programFindVersion = \verbosity ->-      findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity)-  }+stripProgram =+  (simpleProgram "strip")+    { programFindVersion = \verbosity ->+        findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity)+    }  hsc2hsProgram :: Program-hsc2hsProgram = (simpleProgram "hsc2hs") {-    programFindVersion =-      findProgramVersion "--version" $ \str ->-        -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66"-        case words str of-          (_:_:ver:_) -> ver-          _           -> ""-  }+hsc2hsProgram =+  (simpleProgram "hsc2hs")+    { programFindVersion =+        findProgramVersion "--version" $ \str ->+          -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66"+          case words str of+            (_ : _ : ver : _) -> ver+            _ -> ""+    }  c2hsProgram :: Program-c2hsProgram = (simpleProgram "c2hs") {-    programFindVersion = findProgramVersion "--numeric-version" id-  }+c2hsProgram =+  (simpleProgram "c2hs")+    { programFindVersion = findProgramVersion "--numeric-version" id+    }  cpphsProgram :: Program-cpphsProgram = (simpleProgram "cpphs") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      -- Invoking "cpphs --version" gives a string like "cpphs 1.3"-      case words str of-        (_:ver:_) -> ver-        _         -> ""-  }+cpphsProgram =+  (simpleProgram "cpphs")+    { programFindVersion = findProgramVersion "--version" $ \str ->+        -- Invoking "cpphs --version" gives a string like "cpphs 1.3"+        case words str of+          (_ : ver : _) -> ver+          _ -> ""+    }  hscolourProgram :: Program-hscolourProgram = (simpleProgram "hscolour") {-    programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour",-    programFindVersion  = findProgramVersion "-version" $ \str ->-      -- Invoking "HsColour -version" gives a string like "HsColour 1.7"-      case words str of-        (_:ver:_) -> ver-        _         -> ""-  }+hscolourProgram =+  (simpleProgram "hscolour")+    { programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour"+    , programFindVersion = findProgramVersion "-version" $ \str ->+        -- Invoking "HsColour -version" gives a string like "HsColour 1.7"+        case words str of+          (_ : ver : _) -> ver+          _ -> ""+    }  -- TODO: Ensure that doctest is built against the same GHC as the one --       that's being used.  Same for haddock.  @phadej pointed this out. doctestProgram :: Program-doctestProgram = (simpleProgram "doctest") {-    programFindLocation = \v p -> findProgramOnSearchPath v p "doctest"-  , programFindVersion  = findProgramVersion "--version" $ \str ->-         -- "doctest version 0.11.2"-         case words str of-           (_:_:ver:_) -> ver-           _           -> ""-  }+doctestProgram =+  (simpleProgram "doctest")+    { programFindLocation = \v p -> findProgramOnSearchPath v p "doctest"+    , programFindVersion = findProgramVersion "--version" $ \str ->+        -- "doctest version 0.11.2"+        case words str of+          (_ : _ : ver : _) -> ver+          _ -> ""+    }  haddockProgram :: Program-haddockProgram = (simpleProgram "haddock") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      -- Invoking "haddock --version" gives a string like-      -- "Haddock version 0.8, (c) Simon Marlow 2006"-      case words str of-        (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver-        _           -> "",--    programNormaliseArgs = \_ _ args -> args-  }--greencardProgram :: Program-greencardProgram = simpleProgram "greencard"+haddockProgram =+  (simpleProgram "haddock")+    { programFindVersion = findProgramVersion "--version" $ \str ->+        -- Invoking "haddock --version" gives a string like+        -- "Haddock version 0.8, (c) Simon Marlow 2006"+        case words str of+          (_ : _ : ver : _) -> takeWhile (`elem` ('.' : ['0' .. '9'])) ver+          _ -> ""+    , programNormaliseArgs = \_ _ args -> args+    }  ldProgram :: Program-ldProgram = simpleProgram "ld"+ldProgram =+  (simpleProgram "ld")+    { programPostConf = \verbosity ldProg -> do+        -- The `lld` linker cannot create merge (relocatable) objects so we+        -- want to detect this.+        -- If the linker does support relocatable objects, we want to use that+        -- to create partially pre-linked objects for GHCi, so we get much+        -- faster loading as we do not have to do the separate loading and+        -- in-memory linking the static linker in GHC does, but can offload+        -- parts of this process to a pre-linking step.+        -- However this requires the linker to support this features. Not all+        -- linkers do, and notably as of this writing `lld` which is a popular+        -- choice for windows linking does not support this feature. However+        -- if using binutils ld or another linker that supports --relocatable,+        -- we should still be good to generate pre-linked objects.+        ldHelpOutput <-+          getProgramInvocationOutput+            verbosity+            (programInvocation ldProg ["--help"])+            -- In case the linker does not support '--help'. Eg the LLVM linker,+            -- `lld` only accepts `-help`.+            `catchIO` (\_ -> return "")+        let k = "Supports relocatable output"+            -- Standard GNU `ld` uses `--relocatable` while `ld.gold` uses+            -- `-relocatable` (single `-`).+            v+              | "-relocatable" `isInfixOf` ldHelpOutput = "YES"+              -- ld64 on macOS has this lovely response for "--help"+              --+              --   ld64: For information on command line options please use 'man ld'.+              --+              -- it does however support -r, if you read the manpage+              -- (e.g. https://www.manpagez.com/man/1/ld64/)+              | "ld64:" `isPrefixOf` ldHelpOutput = "YES"+              | otherwise = "NO" +            m = Map.insert k v (programProperties ldProg)+        return $ ldProg{programProperties = m}+    }+ tarProgram :: Program-tarProgram = (simpleProgram "tar") {-  -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the-  -- '--format' option.-  programPostConf = \verbosity tarProg -> do-     tarHelpOutput <- getProgramInvocationOutput-                      verbosity (programInvocation tarProg ["--help"])-                      -- Some versions of tar don't support '--help'.-                      `catchIO` (\_ -> return "")-     let k = "Supports --format"-         v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO"-         m = Map.insert k v (programProperties tarProg)-     return $ tarProg { programProperties = m }-  }+tarProgram =+  (simpleProgram "tar")+    { -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the+      -- '--format' option.+      programPostConf = \verbosity tarProg -> do+        tarHelpOutput <-+          getProgramInvocationOutput+            verbosity+            (programInvocation tarProg ["--help"])+            -- Some versions of tar don't support '--help'.+            `catchIO` (\_ -> return "")+        let k = "Supports --format"+            v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO"+            m = Map.insert k v (programProperties tarProg)+        return $ tarProg{programProperties = m}+    }  cppProgram :: Program cppProgram = simpleProgram "cpp"  pkgConfigProgram :: Program-pkgConfigProgram = (simpleProgram "pkg-config") {-    programFindVersion = findProgramVersion "--version" id-  }+pkgConfigProgram =+  (simpleProgram "pkg-config")+    { programFindVersion = findProgramVersion "--version" id+    , programPostConf = \_ pkgConfProg ->+        let programOverrideEnv' =+              programOverrideEnv pkgConfProg+                ++ [ ("PKG_CONFIG_ALLOW_SYSTEM_CFLAGS", Just "1")+                   , ("PKG_CONFIG_ALLOW_SYSTEM_LIBS", Just "1")+                   ]+         in pure $ pkgConfProg{programOverrideEnv = programOverrideEnv'}+    }
src/Distribution/Simple/Program/Db.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE RankNTypes         #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Program.Db -- Copyright   :  Isaac Jones 2006, Duncan Coutts 2007-2009@@ -23,62 +23,72 @@ -- hookedPrograms in 'Distribution.Simple.UserHooks'.  This gives a -- hook user the ability to get the above flags and such so that they -- don't have to write all the PATH logic inside Setup.lhs.--module Distribution.Simple.Program.Db (-    -- * The collection of configured programs we can run-    ProgramDb,-    emptyProgramDb,-    defaultProgramDb,-    restoreProgramDb,+module Distribution.Simple.Program.Db+  ( -- * The collection of configured programs we can run+    ProgramDb (..)+  , emptyProgramDb+  , defaultProgramDb+  , restoreProgramDb      -- ** Query and manipulate the program db-    addKnownProgram,-    addKnownPrograms,-    lookupKnownProgram,-    knownPrograms,-    getProgramSearchPath,-    setProgramSearchPath,-    modifyProgramSearchPath,-    userSpecifyPath,-    userSpecifyPaths,-    userMaybeSpecifyPath,-    userSpecifyArgs,-    userSpecifyArgss,-    userSpecifiedArgs,-    lookupProgram,-    updateProgram,-    configuredPrograms,+  , addKnownProgram+  , addKnownPrograms+  , prependProgramSearchPath+  , prependProgramSearchPathNoLogging+  , lookupKnownProgram+  , knownPrograms+  , getProgramSearchPath+  , setProgramSearchPath+  , modifyProgramSearchPath+  , userSpecifyPath+  , userSpecifyPaths+  , userMaybeSpecifyPath+  , userSpecifyArgs+  , userSpecifyArgss+  , userSpecifiedArgs+  , lookupProgram+  , lookupProgramByName+  , updateProgram+  , configuredPrograms      -- ** Query and manipulate the program db-    configureProgram,-    configureAllKnownPrograms,-    unconfigureProgram,-    lookupProgramVersion,-    reconfigurePrograms,-    requireProgram,-    requireProgramVersion,-    needProgram,+  , configureProgram+  , configureUnconfiguredProgram+  , configureAllKnownPrograms+  , unconfigureProgram+  , lookupProgramVersion+  , reconfigurePrograms+  , requireProgram+  , requireProgramVersion+  , needProgram +    -- * Internal functions+  , UnconfiguredProgs+  , ConfiguredProgs+  , updateUnconfiguredProgs+  , updateConfiguredProgs   ) where  import Distribution.Compat.Prelude import Prelude () -import Distribution.Pretty import Distribution.Simple.Program.Builtin import Distribution.Simple.Program.Find import Distribution.Simple.Program.Types import Distribution.Simple.Utils-import Distribution.Utils.Structured       (Structure (..), Structured (..))+import Distribution.Utils.Structured (Structure (..), Structured (..)) import Distribution.Verbosity import Distribution.Version  import Data.Tuple (swap)  import qualified Data.Map as Map+import Distribution.Simple.Errors  -- ------------------------------------------------------------+ -- * Programs database+ -- ------------------------------------------------------------  -- | The configuration is a collection of information about programs. It@@ -89,75 +99,82 @@ -- by one we try to configure them at which point we move them into the -- configured collection. For unconfigured programs we record not just the -- 'Program' but also any user-provided arguments and location for the program.-data ProgramDb = ProgramDb {-        unconfiguredProgs :: UnconfiguredProgs,-        progSearchPath    :: ProgramSearchPath,-        configuredProgs   :: ConfiguredProgs-    }-  deriving (Typeable)+data ProgramDb = ProgramDb+  { unconfiguredProgs :: UnconfiguredProgs+  , progSearchPath :: ProgramSearchPath+  , progOverrideEnv :: [(String, Maybe String)]+  , configuredProgs :: ConfiguredProgs+  }  type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg])-type UnconfiguredProgs   = Map.Map String UnconfiguredProgram-type ConfiguredProgs     = Map.Map String ConfiguredProgram-+type UnconfiguredProgs = Map.Map String UnconfiguredProgram+type ConfiguredProgs = Map.Map String ConfiguredProgram  emptyProgramDb :: ProgramDb-emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty+emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath [] Map.empty  defaultProgramDb :: ProgramDb defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb - -- internal helpers:-updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs)-                        -> ProgramDb -> ProgramDb+updateUnconfiguredProgs+  :: (UnconfiguredProgs -> UnconfiguredProgs)+  -> ProgramDb+  -> ProgramDb updateUnconfiguredProgs update progdb =-  progdb { unconfiguredProgs = update (unconfiguredProgs progdb) }+  progdb{unconfiguredProgs = update (unconfiguredProgs progdb)} -updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs)-                      -> ProgramDb -> ProgramDb+updateConfiguredProgs+  :: (ConfiguredProgs -> ConfiguredProgs)+  -> ProgramDb+  -> ProgramDb updateConfiguredProgs update progdb =-  progdb { configuredProgs = update (configuredProgs progdb) }-+  progdb{configuredProgs = update (configuredProgs progdb)}  -- Read & Show instances are based on listToFM  -- | Note that this instance does not preserve the known 'Program's. -- See 'restoreProgramDb' for details.--- instance Show ProgramDb where   show = show . Map.toAscList . configuredProgs  -- | Note that this instance does not preserve the known 'Program's. -- See 'restoreProgramDb' for details.--- instance Read ProgramDb where   readsPrec p s =-    [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r)-    | (s', r) <- readsPrec p s ]+    [ (emptyProgramDb{configuredProgs = Map.fromList s'}, r)+    | (s', r) <- readsPrec p s+    ]  -- | Note that this instance does not preserve the known 'Program's. -- See 'restoreProgramDb' for details.--- instance Binary ProgramDb where   put db = do     put (progSearchPath db)+    put (progOverrideEnv db)     put (configuredProgs db)    get = do     searchpath <- get-    progs      <- get-    return $! emptyProgramDb {-      progSearchPath  = searchpath,-      configuredProgs = progs-    }+    overrides <- get+    progs <- get+    return $!+      emptyProgramDb+        { progSearchPath = searchpath+        , progOverrideEnv = overrides+        , configuredProgs = progs+        }  instance Structured ProgramDb where-    structure p = Nominal (typeRep p) 0 "ProgramDb"-        [ structure (Proxy :: Proxy ProgramSearchPath)-        , structure (Proxy :: Proxy ConfiguredProgs)-        ]-+  structure p =+    Nominal+      (typeRep p)+      0+      "ProgramDb"+      [ structure (Proxy :: Proxy ProgramSearchPath)+      , structure (Proxy :: Proxy [(String, Maybe String)])+      , structure (Proxy :: Proxy ConfiguredProgs)+      ]  -- | The 'Read'\/'Show' and 'Binary' instances do not preserve all the -- unconfigured 'Programs' because 'Program' is not in 'Read'\/'Show' because@@ -166,142 +183,177 @@ -- -- * It does not add the default programs, but you probably want them, use --   'builtinPrograms' in addition to any extra you might need.--- restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb restoreProgramDb = addKnownPrograms - -- ------------------------------- -- Managing unconfigured programs  -- | Add a known program that we may configure later--- addKnownProgram :: Program -> ProgramDb -> ProgramDb-addKnownProgram prog = updateUnconfiguredProgs $-  Map.insertWith combine (programName prog) (prog, Nothing, [])-  where combine _ (_, path, args) = (prog, path, args)-+addKnownProgram prog =+  updateUnconfiguredProgs $+    Map.insertWith combine (programName prog) (prog, Nothing, [])+  where+    combine _ (_, path, args) = (prog, path, args)  addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb addKnownPrograms progs progdb = foldl' (flip addKnownProgram) progdb progs - lookupKnownProgram :: String -> ProgramDb -> Maybe Program lookupKnownProgram name =-  fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs-+  fmap (\(p, _, _) -> p) . Map.lookup name . unconfiguredProgs  knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)] knownPrograms progdb =-  [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs progdb)-           , let p' = Map.lookup (programName p) (configuredProgs progdb) ]+  [ (p, p') | (p, _, _) <- Map.elems (unconfiguredProgs progdb), let p' = Map.lookup (programName p) (configuredProgs progdb)+  ]  -- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This is the default list of locations where programs are looked for when -- configuring them. This can be overridden for specific programs (with -- 'userSpecifyPath'), and specific known programs can modify or ignore this -- search path in their own configuration code.--- getProgramSearchPath :: ProgramDb -> ProgramSearchPath getProgramSearchPath = progSearchPath  -- | Change the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This will affect programs that are configured from here on, so you -- should usually set it before configuring any programs.--- setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb-setProgramSearchPath searchpath db = db { progSearchPath = searchpath }+setProgramSearchPath searchpath db = db{progSearchPath = searchpath}  -- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This will affect programs that are configured from here on, so you -- should usually modify it before configuring any programs.----modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath)-                        -> ProgramDb-                        -> ProgramDb+modifyProgramSearchPath+  :: (ProgramSearchPath -> ProgramSearchPath)+  -> ProgramDb+  -> ProgramDb modifyProgramSearchPath f db =   setProgramSearchPath (f $ getProgramSearchPath db) db --- |User-specify this path.  Basically override any path information--- for this program in the configuration. If it's not a known--- program ignore it.+-- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'+-- by prepending the provided extra paths. ---userSpecifyPath :: String   -- ^Program name-                -> FilePath -- ^user-specified path to the program-                -> ProgramDb -> ProgramDb-userSpecifyPath name path = updateUnconfiguredProgs $-  flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args)+--  - Logs the added paths in info verbosity.+--  - Prepends environment variable overrides.+prependProgramSearchPath+  :: Verbosity+  -> [FilePath]+  -> [(String, Maybe FilePath)]+  -> ProgramDb+  -> IO ProgramDb+prependProgramSearchPath verbosity extraPaths extraEnv db = do+  unless (null extraPaths) $+    logExtraProgramSearchPath verbosity extraPaths+  unless (null extraEnv) $+    logExtraProgramOverrideEnv verbosity extraEnv+  return $ prependProgramSearchPathNoLogging extraPaths extraEnv db +prependProgramSearchPathNoLogging+  :: [FilePath]+  -> [(String, Maybe String)]+  -> ProgramDb+  -> ProgramDb+prependProgramSearchPathNoLogging extraPaths extraEnv db =+  let db' = modifyProgramSearchPath (nub . (map ProgramSearchPathDir extraPaths ++)) db+      db'' = db'{progOverrideEnv = extraEnv ++ progOverrideEnv db'}+   in db'' -userMaybeSpecifyPath :: String -> Maybe FilePath-                     -> ProgramDb -> ProgramDb-userMaybeSpecifyPath _    Nothing progdb     = progdb-userMaybeSpecifyPath name (Just path) progdb = userSpecifyPath name path progdb+-- | User-specify this path.  Basically override any path information+--  for this program in the configuration. If it's not a known+--  program ignore it.+userSpecifyPath+  :: String+  -- ^ Program name+  -> FilePath+  -- ^ user-specified path to the program+  -> ProgramDb+  -> ProgramDb+userSpecifyPath name path = updateUnconfiguredProgs $+  flip Map.update name $+    \(prog, _, args) -> Just (prog, Just path, args) +userMaybeSpecifyPath+  :: String+  -> Maybe FilePath+  -> ProgramDb+  -> ProgramDb+userMaybeSpecifyPath _ Nothing progdb = progdb+userMaybeSpecifyPath name (Just path) progdb = userSpecifyPath name path progdb --- |User-specify the arguments for this program.  Basically override--- any args information for this program in the configuration. If it's--- not a known program, ignore it..-userSpecifyArgs :: String    -- ^Program name-                -> [ProgArg] -- ^user-specified args-                -> ProgramDb-                -> ProgramDb+-- | User-specify the arguments for this program.  Basically override+--  any args information for this program in the configuration. If it's+--  not a known program, ignore it..+userSpecifyArgs+  :: String+  -- ^ Program name+  -> [ProgArg]+  -- ^ user-specified args+  -> ProgramDb+  -> ProgramDb userSpecifyArgs name args' =-    updateUnconfiguredProgs-      (flip Map.update name $-         \(prog, path, args) -> Just (prog, path, args ++ args'))-  . updateConfiguredProgs-      (flip Map.update name $-         \prog -> Just prog { programOverrideArgs = programOverrideArgs prog-                                                 ++ args' })-+  updateUnconfiguredProgs+    ( flip Map.update name $+        \(prog, path, args) -> Just (prog, path, args ++ args')+    )+    . updateConfiguredProgs+      ( flip Map.update name $+          \prog ->+            Just+              prog+                { programOverrideArgs =+                    programOverrideArgs prog+                      ++ args'+                }+      )  -- | Like 'userSpecifyPath' but for a list of progs and their paths.----userSpecifyPaths :: [(String, FilePath)]-                 -> ProgramDb-                 -> ProgramDb+userSpecifyPaths+  :: [(String, FilePath)]+  -> ProgramDb+  -> ProgramDb userSpecifyPaths paths progdb =   foldl' (\progdb' (prog, path) -> userSpecifyPath prog path progdb') progdb paths - -- | Like 'userSpecifyPath' but for a list of progs and their args.----userSpecifyArgss :: [(String, [ProgArg])]-                 -> ProgramDb-                 -> ProgramDb+userSpecifyArgss+  :: [(String, [ProgArg])]+  -> ProgramDb+  -> ProgramDb userSpecifyArgss argss progdb =   foldl' (\progdb' (prog, args) -> userSpecifyArgs prog args progdb') progdb argss - -- | Get the path that has been previously specified for a program, if any.--- userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath userSpecifiedPath prog =-  join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs-+  join . fmap (\(_, p, _) -> p) . Map.lookup (programName prog) . unconfiguredProgs  -- | Get any extra args that have been previously specified for a program.--- userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] userSpecifiedArgs prog =-  maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs-+  maybe [] (\(_, _, as) -> as) . Map.lookup (programName prog) . unconfiguredProgs  -- ----------------------------- -- Managing configured programs  -- | Try to find a configured program lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram-lookupProgram prog = Map.lookup (programName prog) . configuredProgs+lookupProgram = lookupProgramByName . programName +-- | Try to find a configured program+lookupProgramByName :: String -> ProgramDb -> Maybe ConfiguredProgram+lookupProgramByName name = Map.lookup name . configuredProgs  -- | Update a configured program in the database.-updateProgram :: ConfiguredProgram -> ProgramDb-                                   -> ProgramDb-updateProgram prog = updateConfiguredProgs $-  Map.insert (programId prog) prog-+updateProgram+  :: ConfiguredProgram+  -> ProgramDb+  -> ProgramDb+updateProgram prog =+  updateConfiguredProgs $+    Map.insert (programId prog) prog  -- | List all configured programs. configuredPrograms :: ProgramDb -> [ConfiguredProgram]@@ -310,11 +362,13 @@ -- --------------------------- -- Configuring known programs --- | Try to configure a specific program. If the program is already included in--- the collection of unconfigured programs then we use any user-supplied--- location and arguments. If the program gets configured successfully it gets--- added to the configured collection.+-- | Try to configure a specific program and add it to the program database. --+-- If the program is already included in the collection of unconfigured programs,+-- then we use any user-supplied location and arguments.+-- If the program gets configured successfully, it gets added to the configured+-- collection.+-- -- Note that it is not a failure if the program cannot be configured. It's only -- a failure if the user supplied a location and the program could not be found -- at that location.@@ -323,57 +377,73 @@ -- front all the programs we will need, so we try to configure them all. -- To verify that a program was actually successfully configured use -- 'requireProgram'.----configureProgram :: Verbosity-                 -> Program-                 -> ProgramDb-                 -> IO ProgramDb+configureProgram+  :: Verbosity+  -> Program+  -> ProgramDb+  -> IO ProgramDb configureProgram verbosity prog progdb = do+  mbConfiguredProg <- configureUnconfiguredProgram verbosity prog progdb+  case mbConfiguredProg of+    Nothing -> return progdb+    Just configuredProg -> do+      let progdb' =+            updateConfiguredProgs+              (Map.insert (programName prog) configuredProg)+              progdb+      return progdb'++-- | Try to configure a specific program. If the program is already included in+-- the collection of unconfigured programs then we use any user-supplied+-- location and arguments.+configureUnconfiguredProgram+  :: Verbosity+  -> Program+  -> ProgramDb+  -> IO (Maybe ConfiguredProgram)+configureUnconfiguredProgram verbosity prog progdb = do   let name = programName prog   maybeLocation <- case userSpecifiedPath prog progdb of-    Nothing   ->+    Nothing ->       programFindLocation prog verbosity (progSearchPath progdb)-      >>= return . fmap (swap . fmap FoundOnSystem . swap)+        >>= return . fmap (swap . fmap FoundOnSystem . swap)     Just path -> do       absolute <- doesExecutableExist path       if absolute         then return (Just (UserSpecified path, []))-        else findProgramOnSearchPath verbosity (progSearchPath progdb) path-             >>= maybe (die' verbosity notFound)-                       (return . Just . swap . fmap UserSpecified . swap)-      where notFound = "Cannot find the program '" ++ name-                     ++ "'. User-specified path '"-                     ++ path ++ "' does not refer to an executable and "-                     ++ "the program is not on the system path."+        else+          findProgramOnSearchPath verbosity (progSearchPath progdb) path+            >>= maybe+              (dieWithException verbosity $ ConfigureProgram name path)+              (return . Just . swap . fmap UserSpecified . swap)   case maybeLocation of-    Nothing -> return progdb+    Nothing -> return Nothing     Just (location, triedLocations) -> do       version <- programFindVersion prog verbosity (locationPath location)       newPath <- programSearchPathAsPATHVar (progSearchPath progdb)-      let configuredProg        = ConfiguredProgram {-            programId           = name,-            programVersion      = version,-            programDefaultArgs  = [],-            programOverrideArgs = userSpecifiedArgs prog progdb,-            programOverrideEnv  = [("PATH", Just newPath)],-            programProperties   = Map.empty,-            programLocation     = location,-            programMonitorFiles = triedLocations-          }+      let configuredProg =+            ConfiguredProgram+              { programId = name+              , programVersion = version+              , programDefaultArgs = []+              , programOverrideArgs = userSpecifiedArgs prog progdb+              , programOverrideEnv = [("PATH", Just newPath)] ++ progOverrideEnv progdb+              , programProperties = Map.empty+              , programLocation = location+              , programMonitorFiles = triedLocations+              }       configuredProg' <- programPostConf prog verbosity configuredProg-      return (updateConfiguredProgs (Map.insert name configuredProg') progdb)-+      return $ Just configuredProg'  -- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'.----configurePrograms :: Verbosity-                  -> [Program]-                  -> ProgramDb-                  -> IO ProgramDb+configurePrograms+  :: Verbosity+  -> [Program]+  -> ProgramDb+  -> IO ProgramDb configurePrograms verbosity progs progdb =   foldM (flip (configureProgram verbosity)) progdb progs - -- | Unconfigure a program.  This is basically a hack and you shouldn't -- use it, but it can be handy for making sure a 'requireProgram' -- actually reconfigures.@@ -382,51 +452,51 @@   updateConfiguredProgs $ Map.delete progname  -- | Try to configure all the known programs that have not yet been configured.----configureAllKnownPrograms :: Verbosity-                          -> ProgramDb-                          -> IO ProgramDb+configureAllKnownPrograms+  :: Verbosity+  -> ProgramDb+  -> IO ProgramDb configureAllKnownPrograms verbosity progdb =-  configurePrograms verbosity-    [ prog | (prog,_,_) <- Map.elems notYetConfigured ] progdb+  configurePrograms+    verbosity+    [prog | (prog, _, _) <- Map.elems notYetConfigured]+    progdb   where-    notYetConfigured = unconfiguredProgs progdb-      `Map.difference` configuredProgs progdb-+    notYetConfigured =+      unconfiguredProgs progdb+        `Map.difference` configuredProgs progdb  -- | reconfigure a bunch of programs given new user-specified args. It takes -- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs -- with a new path it calls 'configureProgram'.----reconfigurePrograms :: Verbosity-                    -> [(String, FilePath)]-                    -> [(String, [ProgArg])]-                    -> ProgramDb-                    -> IO ProgramDb+reconfigurePrograms+  :: Verbosity+  -> [(String, FilePath)]+  -> [(String, [ProgArg])]+  -> ProgramDb+  -> IO ProgramDb reconfigurePrograms verbosity paths argss progdb = do   configurePrograms verbosity progs-   . userSpecifyPaths paths-   . userSpecifyArgss argss-   $ progdb-+    . userSpecifyPaths paths+    . userSpecifyArgss argss+    $ progdb   where-    progs = catMaybes [ lookupKnownProgram name progdb | (name,_) <- paths ]-+    progs = catMaybes [lookupKnownProgram name progdb | (name, _) <- paths]  -- | Check that a program is configured and available to be run. -- -- It raises an exception if the program could not be configured, otherwise -- it returns the configured program.----requireProgram :: Verbosity -> Program -> ProgramDb-               -> IO (ConfiguredProgram, ProgramDb)+requireProgram+  :: Verbosity+  -> Program+  -> ProgramDb+  -> IO (ConfiguredProgram, ProgramDb) requireProgram verbosity prog progdb = do-    mres <- needProgram verbosity prog progdb-    case mres of-        Nothing  -> die' verbosity notFound-        Just res -> return res-  where-    notFound = "The program '" ++ programName prog ++ "' is required but it could not be found."+  mres <- needProgram verbosity prog progdb+  case mres of+    Nothing -> dieWithException verbosity $ RequireProgram (programName prog)+    Just res -> return res  -- | Check that a program is configured and available to be run. --@@ -434,17 +504,19 @@ -- or is not found. -- -- @since 3.0.1.0-needProgram :: Verbosity -> Program -> ProgramDb-            -> IO (Maybe (ConfiguredProgram, ProgramDb))+needProgram+  :: Verbosity+  -> Program+  -> ProgramDb+  -> IO (Maybe (ConfiguredProgram, ProgramDb)) needProgram verbosity prog progdb = do-   -- If it's not already been configured, try to configure it now   progdb' <- case lookupProgram prog progdb of     Nothing -> configureProgram verbosity prog progdb-    Just _  -> return progdb+    Just _ -> return progdb    case lookupProgram prog progdb' of-    Nothing             -> return Nothing+    Nothing -> return Nothing     Just configuredProg -> return (Just (configuredProg, progdb'))  -- | Check that a program is configured and available to be run.@@ -456,50 +528,39 @@ -- It returns the configured program, its version number and a possibly updated -- 'ProgramDb'. If the program could not be configured or the version is -- unsuitable, it returns an error value.--- lookupProgramVersion-  :: Verbosity -> Program -> VersionRange -> ProgramDb-  -> IO (Either String (ConfiguredProgram, Version, ProgramDb))+  :: Verbosity+  -> Program+  -> VersionRange+  -> ProgramDb+  -> IO (Either CabalException (ConfiguredProgram, Version, ProgramDb)) lookupProgramVersion verbosity prog range programDb = do-   -- If it's not already been configured, try to configure it now   programDb' <- case lookupProgram prog programDb of     Nothing -> configureProgram verbosity prog programDb-    Just _  -> return programDb+    Just _ -> return programDb    case lookupProgram prog programDb' of-    Nothing                           -> return $! Left notFound-    Just configuredProg@ConfiguredProgram { programLocation = location } ->+    Nothing -> return $! Left $ NoProgramFound (programName prog) range+    Just configuredProg@ConfiguredProgram{programLocation = location} ->       case programVersion configuredProg of         Just version           | withinRange version range ->-            return $! Right (configuredProg, version ,programDb')-          | otherwise                 ->-            return $! Left (badVersion version location)-        Nothing                       ->-          return $! Left (unknownVersion location)--  where notFound       = "The program '"-                      ++ programName prog ++ "'" ++ versionRequirement-                      ++ " is required but it could not be found."-        badVersion v l = "The program '"-                      ++ programName prog ++ "'" ++ versionRequirement-                      ++ " is required but the version found at "-                      ++ locationPath l ++ " is version " ++ prettyShow v-        unknownVersion l = "The program '"-                      ++ programName prog ++ "'" ++ versionRequirement-                      ++ " is required but the version of "-                      ++ locationPath l ++ " could not be determined."-        versionRequirement-          | isAnyVersion range = ""-          | otherwise          = " version " ++ prettyShow range+              return $! Right (configuredProg, version, programDb')+          | otherwise ->+              return $! Left $ BadVersionDb (programName prog) version range (locationPath location)+        Nothing ->+          return $! Left $ UnknownVersionDb (programName prog) range (locationPath location)  -- | Like 'lookupProgramVersion', but raises an exception in case of error -- instead of returning 'Left errMsg'.----requireProgramVersion :: Verbosity -> Program -> VersionRange-                      -> ProgramDb-                      -> IO (ConfiguredProgram, Version, ProgramDb)+requireProgramVersion+  :: Verbosity+  -> Program+  -> VersionRange+  -> ProgramDb+  -> IO (ConfiguredProgram, Version, ProgramDb) requireProgramVersion verbosity prog range programDb =-  join $ either (die' verbosity) return `fmap`-  lookupProgramVersion verbosity prog range programDb+  join $+    either (dieWithException verbosity) return+      `fmap` lookupProgramVersion verbosity prog range programDb
src/Distribution/Simple/Program/Find.hs view
@@ -1,10 +1,9 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Program.Find -- Copyright   :  Duncan Coutts 2013@@ -24,139 +23,173 @@ -- So we need an extension of the usual 'findExecutable' that can look in -- additional locations, either before, after or instead of the normal OS -- locations.----module Distribution.Simple.Program.Find (-    -- * Program search path-    ProgramSearchPath,-    ProgramSearchPathEntry(..),-    defaultProgramSearchPath,-    findProgramOnSearchPath,-    programSearchPathAsPATHVar,-    getSystemSearchPath,+module Distribution.Simple.Program.Find+  ( -- * Program search path+    ProgramSearchPath+  , ProgramSearchPathEntry (..)+  , defaultProgramSearchPath+  , findProgramOnSearchPath+  , programSearchPathAsPATHVar+  , logExtraProgramSearchPath+  , logExtraProgramOverrideEnv+  , getSystemSearchPath+  , getExtraPathEnv+  , simpleProgram   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Verbosity+import Distribution.Compat.Environment+import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.System-import Distribution.Compat.Environment+import Distribution.Verbosity  import qualified System.Directory as Directory-         ( findExecutable )+  ( findExecutable+  ) import System.FilePath as FilePath-         ( (</>), (<.>), splitSearchPath, searchPathSeparator, getSearchPath-         , takeDirectory )+  ( getSearchPath+  , searchPathSeparator+  , splitSearchPath+  , takeDirectory+  , (<.>)+  , (</>)+  ) #if defined(mingw32_HOST_OS) import qualified System.Win32 as Win32 #endif --- | A search path to use when locating executables. This is analogous--- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use--- the system default method for finding executables ('findExecutable' which--- on unix is simply looking on the @$PATH@ but on win32 is a bit more--- complicated).------ The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs--- either before, after or instead of the default, e.g. here we add an extra--- dir to search after the usual ones.------ > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir]----type ProgramSearchPath = [ProgramSearchPathEntry]-data ProgramSearchPathEntry =-         ProgramSearchPathDir FilePath  -- ^ A specific dir-       | ProgramSearchPathDefault       -- ^ The system default-  deriving (Eq, Generic, Typeable)--instance Binary ProgramSearchPathEntry-instance Structured ProgramSearchPathEntry- defaultProgramSearchPath :: ProgramSearchPath defaultProgramSearchPath = [ProgramSearchPathDefault] -findProgramOnSearchPath :: Verbosity -> ProgramSearchPath-                        -> FilePath -> IO (Maybe (FilePath, [FilePath]))+logExtraProgramSearchPath+  :: Verbosity+  -> [FilePath]+  -> IO ()+logExtraProgramSearchPath verbosity extraPaths =+  info verbosity . unlines $+    "Including the following directories in PATH:"+      : map ("- " ++) extraPaths++logExtraProgramOverrideEnv+  :: Verbosity+  -> [(String, Maybe String)]+  -> IO ()+logExtraProgramOverrideEnv verbosity extraEnv =+  info verbosity . unlines $+    "Including the following environment variable overrides:"+      : [ "- " ++ case mbVal of+          Nothing -> "unset " ++ var+          Just val -> var ++ "=" ++ val+        | (var, mbVal) <- extraEnv+        ]++findProgramOnSearchPath+  :: Verbosity+  -> ProgramSearchPath+  -> FilePath+  -> IO (Maybe (FilePath, [FilePath])) findProgramOnSearchPath verbosity searchpath prog = do-    debug verbosity $ "Searching for " ++ prog ++ " in path."-    res <- tryPathElems [] searchpath-    case res of-      Nothing   -> debug verbosity ("Cannot find " ++ prog ++ " on the path")-      Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at "++ path)-    return res+  debug verbosity $ "Searching for " ++ prog ++ " in path."+  res <- tryPathElems [] searchpath+  case res of+    Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path")+    Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at " ++ path)+  return res   where-    tryPathElems :: [[FilePath]] -> [ProgramSearchPathEntry]-                 -> IO (Maybe (FilePath, [FilePath]))-    tryPathElems _     []       = return Nothing-    tryPathElems tried (pe:pes) = do+    tryPathElems+      :: [[FilePath]]+      -> [ProgramSearchPathEntry]+      -> IO (Maybe (FilePath, [FilePath]))+    tryPathElems _ [] = return Nothing+    tryPathElems tried (pe : pes) = do       res <- tryPathElem pe       case res of-        (Nothing,      notfoundat) -> tryPathElems (notfoundat : tried) pes+        (Nothing, notfoundat) -> tryPathElems (notfoundat : tried) pes         (Just foundat, notfoundat) -> return (Just (foundat, alltried))           where             alltried = concat (reverse (notfoundat : tried))      tryPathElem :: ProgramSearchPathEntry -> IO (Maybe FilePath, [FilePath])     tryPathElem (ProgramSearchPathDir dir) =-        findFirstExe [ dir </> prog <.> ext | ext <- exeExtensions ]-+      findFirstExe [dir </> prog <.> ext | ext <- exeExtensions]     -- On windows, getSystemSearchPath is not guaranteed 100% correct so we     -- use findExecutable and then approximate the not-found-at locations.     tryPathElem ProgramSearchPathDefault | buildOS == Windows = do-      mExe    <- firstJustM [ findExecutable (prog <.> ext) | ext <- exeExtensions ]+      mExe <- firstJustM [findExecutable (prog <.> ext) | ext <- exeExtensions]       syspath <- getSystemSearchPath       case mExe of         Nothing ->-          let notfoundat = [ dir </> prog | dir <- syspath ] in-          return (Nothing, notfoundat)-+          let notfoundat = [dir </> prog | dir <- syspath]+           in return (Nothing, notfoundat)         Just foundat -> do-          let founddir   = takeDirectory foundat-              notfoundat = [ dir </> prog-                           | dir <- takeWhile (/= founddir) syspath ]+          let founddir = takeDirectory foundat+              notfoundat =+                [ dir </> prog+                | dir <- takeWhile (/= founddir) syspath+                ]           return (Just foundat, notfoundat)      -- On other OSs we can just do the simple thing     tryPathElem ProgramSearchPathDefault = do       dirs <- getSystemSearchPath-      findFirstExe [ dir </> prog <.> ext | dir <- dirs, ext <- exeExtensions ]+      findFirstExe [dir </> prog <.> ext | dir <- dirs, ext <- exeExtensions]      findFirstExe :: [FilePath] -> IO (Maybe FilePath, [FilePath])     findFirstExe = go []       where-        go fs' []     = return (Nothing, reverse fs')-        go fs' (f:fs) = do+        go fs' [] = return (Nothing, reverse fs')+        go fs' (f : fs) = do           isExe <- doesExecutableExist f           if isExe             then return (Just f, reverse fs')-            else go (f:fs') fs+            else go (f : fs') fs      -- Helper for evaluating actions until the first one returns 'Just'     firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a)     firstJustM [] = return Nothing-    firstJustM (ma:mas) = do+    firstJustM (ma : mas) = do       a <- ma       case a of-        Just _  -> return a+        Just _ -> return a         Nothing -> firstJustM mas +-- | Adds some paths to the "PATH" entry in the key-value environment provided+-- or if there is none, looks up @$PATH@ in the real environment.+getExtraPathEnv+  :: Verbosity+  -> [(String, Maybe String)]+  -> [FilePath]+  -> IO [(String, Maybe String)]+getExtraPathEnv _ _ [] = return []+getExtraPathEnv verbosity env extras = do+  mb_path <- case lookup "PATH" env of+    Just x -> return x+    Nothing -> lookupEnv "PATH"+  logExtraProgramSearchPath verbosity extras+  let extra = intercalate [searchPathSeparator] extras+      path' = case mb_path of+        Nothing -> extra+        Just path -> extra ++ searchPathSeparator : path+  return [("PATH", Just path')]+ -- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var. -- Note that this is close but not perfect because on Windows the search -- algorithm looks at more than just the @%PATH%@. programSearchPathAsPATHVar :: ProgramSearchPath -> IO String programSearchPathAsPATHVar searchpath = do-    ess <- traverse getEntries searchpath-    return (intercalate [searchPathSeparator] (concat ess))+  ess <- traverse getEntries searchpath+  return (intercalate [searchPathSeparator] (concat ess))   where     getEntries (ProgramSearchPathDir dir) = return [dir]-    getEntries ProgramSearchPathDefault   = do+    getEntries ProgramSearchPathDefault = do       env <- getEnvironment       return (maybe [] splitSearchPath (lookup "PATH" env))  -- | Get the system search path. On Unix systems this is just the @$PATH@ env -- var, but on windows it's a bit more complicated.--- getSystemSearchPath :: IO [FilePath] getSystemSearchPath = fmap nub $ do #if defined(mingw32_HOST_OS)@@ -196,3 +229,18 @@         _     -> return mExe #endif +-- | Make a simple named program.+--+-- By default we'll just search for it in the path and not try to find the+-- version name. You can override these behaviours if necessary, eg:+--+-- > (simpleProgram "foo") { programFindLocation = ... , programFindVersion ... }+simpleProgram :: String -> Program+simpleProgram name =+  Program+    { programName = name+    , programFindLocation = \v p -> findProgramOnSearchPath v p name+    , programFindVersion = \_ _ -> return Nothing+    , programPostConf = \_ p -> return p+    , programNormaliseArgs = \_ _ -> id+    }
src/Distribution/Simple/Program/GHC.hs view
@@ -1,843 +1,1078 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Distribution.Simple.Program.GHC (-    GhcOptions(..),-    GhcMode(..),-    GhcOptimisation(..),-    GhcDynLinkMode(..),-    GhcProfAuto(..),--    ghcInvocation,-    renderGhcOptions,--    runGHC,--    packageDbArgsDb,-    normaliseGhcArgs--  ) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Backpack-import Distribution.Compat.Semigroup (First'(..), Last'(..), Option'(..))-import Distribution.Simple.GHC.ImplInfo-import Distribution.PackageDescription-import Distribution.ModuleName-import Distribution.Simple.Compiler-import Distribution.Simple.Flag-import Distribution.Simple.Program.Types-import Distribution.Simple.Program.Run-import Distribution.System-import Distribution.Pretty-import Distribution.Types.ComponentId-import Distribution.Verbosity-import Distribution.Version-import Distribution.Utils.NubList-import Language.Haskell.Extension--import Data.List (stripPrefix)-import qualified Data.Map as Map-import Data.Monoid (All(..), Any(..), Endo(..))-import qualified Data.Set as Set--normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String]-normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs-   | ghcVersion `withinRange` supportedGHCVersions-   = argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs-  where-    supportedGHCVersions :: VersionRange-    supportedGHCVersions = intersectVersionRanges-        (orLaterVersion (mkVersion [8,0]))-        (earlierVersion (mkVersion [9,1]))--    from :: Monoid m => [Int] -> m -> m-    from version flags-      | ghcVersion `withinRange` orLaterVersion (mkVersion version) = flags-      | otherwise = mempty--    to :: Monoid m => [Int] -> m -> m-    to version flags-      | ghcVersion `withinRange` earlierVersion (mkVersion version) = flags-      | otherwise = mempty--    checkGhcFlags :: forall m . Monoid m => ([String] -> m) -> m-    checkGhcFlags fun = mconcat-        [ fun ghcArgs-        , checkComponentFlags libBuildInfo pkgLibs-        , checkComponentFlags buildInfo executables-        , checkComponentFlags testBuildInfo testSuites-        , checkComponentFlags benchmarkBuildInfo benchmarks-        ]-      where-        pkgLibs = maybeToList library ++ subLibraries--        checkComponentFlags :: (a -> BuildInfo) -> [a] -> m-        checkComponentFlags getInfo = foldMap (checkComponent . getInfo)-          where-            checkComponent :: BuildInfo -> m-            checkComponent = foldMap fun . filterGhcOptions . allGhcOptions--            allGhcOptions :: BuildInfo -> [(CompilerFlavor, [String])]-            allGhcOptions = foldMap (perCompilerFlavorToList .)-                [options, profOptions, sharedOptions, staticOptions]--            filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]]-            filterGhcOptions l = [opts | (GHC, opts) <- l]--    safeToFilterWarnings :: Bool-    safeToFilterWarnings = getAll $ checkGhcFlags checkWarnings-      where-        checkWarnings :: [String] -> All-        checkWarnings = All . Set.null . foldr alter Set.empty--        alter :: String -> Set String -> Set String-        alter flag = appEndo $ mconcat-            [ \s -> Endo $ if s == "-Werror" then Set.insert s else id-            , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id-            , \s -> from [8,6] . Endo $-                    if s == "-Werror=compat"-                    then Set.union compatWarningSet else id-            , \s -> from [8,6] . Endo $-                    if s == "-Wno-error=compat"-                    then (`Set.difference` compatWarningSet) else id-            , \s -> from [8,6] . Endo $-                    if s == "-Wwarn=compat"-                    then (`Set.difference` compatWarningSet) else id-            , from [8,4] $ markFlag "-Werror=" Set.insert-            , from [8,4] $ markFlag "-Wwarn=" Set.delete-            , from [8,4] $ markFlag "-Wno-error=" Set.delete-            ] flag--        markFlag-            :: String-            -> (String -> Set String -> Set String)-            -> String-            -> Endo (Set String)-        markFlag name update flag = Endo $ case stripPrefix name flag of-            Just rest | not (null rest) && rest /= "compat" -> update rest-            _ -> id--    flagArgumentFilter :: [String] -> [String] -> [String]-    flagArgumentFilter flags = go-      where-        makeFilter :: String -> String -> Option' (First' ([String] -> [String]))-        makeFilter flag arg = Option' $ First' . filterRest <$> stripPrefix flag arg-          where-            filterRest leftOver = case dropEq leftOver of-                [] -> drop 1-                _ -> id--        checkFilter :: String -> Maybe ([String] -> [String])-        checkFilter = fmap getFirst' . getOption' . foldMap makeFilter flags--        go :: [String] -> [String]-        go [] = []-        go (arg:args) = case checkFilter arg of-            Just f -> go (f args)-            Nothing -> arg : go args--    argumentFilters :: [String] -> [String]-    argumentFilters = flagArgumentFilter-        ["-ghci-script", "-H", "-interactive-print"]--    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:)--    simpleFilters :: String -> Bool-    simpleFilters = not . getAny . mconcat-      [ flagIn simpleFlags-      , Any . isPrefixOf "-ddump-"-      , Any . isPrefixOf "-dsuppress-"-      , Any . isPrefixOf "-dno-suppress-"-      , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"]-      , flagIn . invertibleFlagSet "-f" . mconcat $-            [ [ "reverse-errors", "warn-unused-binds", "break-on-error"-              , "break-on-exception", "print-bind-result"-              , "print-bind-contents", "print-evld-with-show"-              , "implicit-import-qualified", "error-spans"-              ]-            , from [7,8]-              [ "print-explicit-foralls" -- maybe also earlier, but GHC-7.6 doesn't have --show-options-              , "print-explicit-kinds"-              ]-            , from [8,0]-              [ "print-explicit-coercions"-              , "print-explicit-runtime-reps"-              , "print-equality-relations"-              , "print-unicode-syntax"-              , "print-expanded-synonyms"-              , "print-potential-instances"-              , "print-typechecker-elaboration"-              ]-            , from [8,2]-                [ "diagnostics-show-caret", "local-ghci-history"-                , "show-warning-groups", "hide-source-paths"-                , "show-hole-constraints"-                ]-            , from [8,4] ["show-loaded-modules"]-            , from [8,6] [ "ghci-leak-check", "no-it" ]-            , from [8,10]-                [ "defer-diagnostics"      -- affects printing of diagnostics-                , "keep-going"             -- try harder, the build will still fail if it's erroneous-                , "print-axiom-incomps"    -- print more debug info for closed type families-                ]-            ]-      , flagIn . invertibleFlagSet "-d" $ [ "ppr-case-as-let", "ppr-ticks" ]-      , isOptIntFlag-      , isIntFlag-      , if safeToFilterWarnings-           then isWarning <> (Any . ("-w"==))-           else mempty-      , from [8,6] $-        if safeToFilterHoles-           then isTypedHoleFlag-           else mempty-      ]--    flagIn :: Set String -> String -> Any-    flagIn set flag = Any $ Set.member flag set--    isWarning :: String -> Any-    isWarning = mconcat $ map ((Any .) . isPrefixOf)-        ["-fwarn-", "-fno-warn-", "-W", "-Wno-"]--    simpleFlags :: Set String-    simpleFlags = Set.fromList . mconcat $-      [ [ "-n", "-#include", "-Rghc-timing", "-dstg-stats"-        , "-dth-dec-file", "-dsource-stats", "-dverbose-core2core"-        , "-dverbose-stg2stg", "-dcore-lint", "-dstg-lint", "-dcmm-lint"-        , "-dasm-lint", "-dannot-lint", "-dshow-passes", "-dfaststring-stats"-        , "-fno-max-relevant-binds", "-recomp", "-no-recomp", "-fforce-recomp"-        , "-fno-force-recomp"-        ]--      , from [8,2]-          [ "-fno-max-errors", "-fdiagnostics-color=auto"-          , "-fdiagnostics-color=always", "-fdiagnostics-color=never"-          , "-dppr-debug", "-dno-debug-output"-          ]--      , from [8,4] [ "-ddebug-output" ]-      , from [8,4] $ to [8,6] [ "-fno-max-valid-substitutions" ]-      , from [8,6] [ "-dhex-word-literals" ]-      , from [8,8] [ "-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits" ]-      , from [9,0] [ "-dlinear-core-lint" ]-      ]--    isOptIntFlag :: String -> Any-    isOptIntFlag = mconcat . map (dropIntFlag True) $ ["-v", "-j"]--    isIntFlag :: String -> Any-    isIntFlag = mconcat . map (dropIntFlag False) . mconcat $-        [ [ "-fmax-relevant-binds", "-ddpr-user-length", "-ddpr-cols"-          , "-dtrace-level", "-fghci-hist-size" ]-        , from [8,2] ["-fmax-uncovered-patterns", "-fmax-errors"]-        , from [8,4] $ to [8,6] ["-fmax-valid-substitutions"]-        ]--    dropIntFlag :: Bool -> String -> String -> Any-    dropIntFlag isOpt flag input = Any $ case stripPrefix flag input of-        Nothing -> False-        Just rest | isOpt && null rest -> True-                  | otherwise -> case parseInt rest of-                        Just _ -> True-                        Nothing -> False-      where-        parseInt :: String -> Maybe Int-        parseInt = readMaybe . dropEq--    dropEq :: String -> String-    dropEq ('=':s) = s-    dropEq s = s--    invertibleFlagSet :: String -> [String] -> Set String-    invertibleFlagSet prefix flagNames =-      Set.fromList $ (++) <$> [prefix, prefix ++ "no-"] <*> flagNames--    compatWarningSet :: Set String-    compatWarningSet = Set.fromList $ mconcat-        [ from [8,6]-            [ "missing-monadfail-instances", "semigroup"-            , "noncanonical-monoid-instances", "implicit-kind-vars" ]-        ]--    safeToFilterHoles :: Bool-    safeToFilterHoles = getAll . checkGhcFlags $-        All . fromMaybe True . fmap getLast' . getOption' . 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--    isTypedHoleFlag :: String -> Any-    isTypedHoleFlag = mconcat-        [ flagIn . invertibleFlagSet "-f" $-            [ "show-hole-constraints", "show-valid-substitutions"-            , "show-valid-hole-fits", "sort-valid-hole-fits"-            , "sort-by-size-hole-fits", "sort-by-subsumption-hole-fits"-            , "abstract-refinement-hole-fits", "show-provenance-of-hole-fits"-            , "show-hole-matches-of-hole-fits", "show-type-of-hole-fits"-            , "show-type-app-of-hole-fits", "show-type-app-vars-of-hole-fits"-            , "unclutter-valid-hole-fits"-            ]-        , flagIn . Set.fromList $-            [ "-fno-max-valid-hole-fits", "-fno-max-refinement-hole-fits"-            , "-fno-refinement-level-hole-fits" ]-        , mconcat . map (dropIntFlag False) $-            [ "-fmax-valid-hole-fits", "-fmax-refinement-hole-fits"-            , "-frefinement-level-hole-fits" ]-        ]--normaliseGhcArgs _ _ args = args---- | A structured set of GHC options/flags------ Note that options containing lists fall into two categories:------  * options that can be safely deduplicated, e.g. input modules or---    enabled extensions;---  * options that cannot be deduplicated in general without changing---    semantics, e.g. extra ghc options or linking options.-data GhcOptions = GhcOptions {--  -- | The major mode for the ghc invocation.-  ghcOptMode          :: Flag GhcMode,--  -- | Any extra options to pass directly to ghc. These go at the end and hence-  -- override other stuff.-  ghcOptExtra         :: [String],--  -- | Extra default flags to pass directly to ghc. These go at the beginning-  -- and so can be overridden by other stuff.-  ghcOptExtraDefault  :: [String],--  ------------------------  -- Inputs and outputs--  -- | The main input files; could be .hs, .hi, .c, .o, depending on mode.-  ghcOptInputFiles    :: NubListR FilePath,--  -- | The names of input Haskell modules, mainly for @--make@ mode.-  ghcOptInputModules  :: NubListR ModuleName,--  -- | Location for output file; the @ghc -o@ flag.-  ghcOptOutputFile    :: Flag FilePath,--  -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode;-  -- the @ghc -dyno@ flag.-  ghcOptOutputDynFile :: Flag FilePath,--  -- | Start with an empty search path for Haskell source files;-  -- the @ghc -i@ flag (@-i@ on its own with no path argument).-  ghcOptSourcePathClear :: Flag Bool,--  -- | Search path for Haskell source files; the @ghc -i@ flag.-  ghcOptSourcePath    :: NubListR FilePath,--  --------------  -- Packages--  -- | The unit ID the modules will belong to; the @ghc -this-unit-id@-  -- flag (or @-this-package-key@ or @-package-name@ on older-  -- versions of GHC).  This is a 'String' because we assume you've-  -- already figured out what the correct format for this string is-  -- (we need to handle backwards compatibility.)-  ghcOptThisUnitId   :: Flag String,--  -- | GHC doesn't make any assumptions about the format of-  -- definite unit ids, so when we are instantiating a package it-  -- needs to be told explicitly what the component being instantiated-  -- is.  This only gets set when 'ghcOptInstantiatedWith' is non-empty-  ghcOptThisComponentId :: Flag ComponentId,--  -- | How the requirements of the package being compiled are to-  -- be filled.  When typechecking an indefinite package, the 'OpenModule'-  -- is always a 'OpenModuleVar'; otherwise, it specifies the installed module-  -- that instantiates a package.-  ghcOptInstantiatedWith :: [(ModuleName, OpenModule)],--  -- | No code? (But we turn on interface writing-  ghcOptNoCode :: Flag Bool,--  -- | GHC package databases to use, the @ghc -package-conf@ flag.-  ghcOptPackageDBs    :: PackageDBStack,--  -- | The GHC packages to bring into scope when compiling,-  -- the @ghc -package-id@ flags.-  ghcOptPackages      ::-    NubListR (OpenUnitId, ModuleRenaming),--  -- | Start with a clean package set; the @ghc -hide-all-packages@ flag-  ghcOptHideAllPackages :: Flag Bool,--  -- | Warn about modules, not listed in command line-  ghcOptWarnMissingHomeModules :: Flag Bool,--  -- | Don't automatically link in Haskell98 etc; the @ghc-  -- -no-auto-link-packages@ flag.-  ghcOptNoAutoLinkPackages :: Flag Bool,--  ------------------  -- Linker stuff--  -- | Names of libraries to link in; the @ghc -l@ flag.-  ghcOptLinkLibs      :: [FilePath],--  -- | Search path for libraries to link in; the @ghc -L@ flag.-  ghcOptLinkLibPath  :: NubListR FilePath,--  -- | Options to pass through to the linker; the @ghc -optl@ flag.-  ghcOptLinkOptions   :: [String],--  -- | OSX only: frameworks to link in; the @ghc -framework@ flag.-  ghcOptLinkFrameworks :: NubListR String,--  -- | OSX only: Search path for frameworks to link in; the-  -- @ghc -framework-path@ flag.-  ghcOptLinkFrameworkDirs :: NubListR String,--  -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag.-  ghcOptNoLink :: Flag Bool,--  -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@-  -- flag.-  ghcOptLinkNoHsMain :: Flag Bool,--  -- | Module definition files (Windows specific)-  ghcOptLinkModDefFiles :: NubListR FilePath,--  ---------------------  -- C and CPP stuff--  -- | Options to pass through to the C compiler; the @ghc -optc@ flag.-  ghcOptCcOptions     :: [String],--  -- | Options to pass through to the C++ compiler.-  ghcOptCxxOptions     :: [String],--  -- | Options to pass through to the Assembler.-  ghcOptAsmOptions     :: [String],--  -- | Options to pass through to CPP; the @ghc -optP@ flag.-  ghcOptCppOptions    :: [String],--  -- | Search path for CPP includes like header files; the @ghc -I@ flag.-  ghcOptCppIncludePath :: NubListR FilePath,--  -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag.-  ghcOptCppIncludes    :: NubListR FilePath,--  -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag.-  ghcOptFfiIncludes    :: NubListR FilePath,--  -----------------------------  -- Language and extensions--  -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag.-  ghcOptLanguage      :: Flag Language,--  -- | The language extensions; the @ghc -X@ flag.-  ghcOptExtensions    :: NubListR Extension,--  -- | A GHC version-dependent mapping of extensions to flags. This must be-  -- set to be able to make use of the 'ghcOptExtensions'.-  ghcOptExtensionMap    :: Map Extension (Maybe CompilerFlag),--  -----------------  -- Compilation--  -- | What optimisation level to use; the @ghc -O@ flag.-  ghcOptOptimisation  :: Flag GhcOptimisation,--    -- | Emit debug info; the @ghc -g@ flag.-  ghcOptDebugInfo     :: Flag DebugInfoLevel,--  -- | Compile in profiling mode; the @ghc -prof@ flag.-  ghcOptProfilingMode :: Flag Bool,--  -- | Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags.-  ghcOptProfilingAuto :: Flag GhcProfAuto,--  -- | Use the \"split sections\" feature; the @ghc -split-sections@ flag.-  ghcOptSplitSections :: Flag Bool,--  -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag.-  ghcOptSplitObjs     :: Flag Bool,--  -- | Run N jobs simultaneously (if possible).-  ghcOptNumJobs       :: Flag (Maybe Int),--  -- | Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags.-  ghcOptHPCDir        :: Flag FilePath,--  -----------------  -- GHCi--  -- | Extra GHCi startup scripts; the @-ghci-script@ flag-  ghcOptGHCiScripts    :: [FilePath],--  -------------------------  -- Redirecting outputs--  ghcOptHiSuffix      :: Flag String,-  ghcOptObjSuffix     :: Flag String,-  ghcOptDynHiSuffix   :: Flag String,   -- ^ only in 'GhcStaticAndDynamic' mode-  ghcOptDynObjSuffix  :: Flag String,   -- ^ only in 'GhcStaticAndDynamic' mode-  ghcOptHiDir         :: Flag FilePath,-  ghcOptObjDir        :: Flag FilePath,-  ghcOptOutputDir     :: Flag FilePath,-  ghcOptStubDir       :: Flag FilePath,--  ---------------------  -- Creating libraries--  ghcOptDynLinkMode   :: Flag GhcDynLinkMode,-  ghcOptStaticLib     :: Flag Bool,-  ghcOptShared        :: Flag Bool,-  ghcOptFPic          :: Flag Bool,-  ghcOptDylibName     :: Flag String,-  ghcOptRPaths        :: NubListR FilePath,--  ----------------  -- Misc flags--  -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag.-  ghcOptVerbosity     :: Flag Verbosity,--  -- | Put the extra folders in the PATH environment variable we invoke-  -- GHC with-  ghcOptExtraPath     :: NubListR FilePath,--  -- | Let GHC know that it is Cabal that's calling it.-  -- Modifies some of the GHC error messages.-  ghcOptCabal         :: Flag Bool--} deriving (Show, Generic)---data GhcMode = GhcModeCompile     -- ^ @ghc -c@-             | GhcModeLink        -- ^ @ghc@-             | GhcModeMake        -- ^ @ghc --make@-             | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@-             | GhcModeAbiHash     -- ^ @ghc --abi-hash@---             | GhcModeDepAnalysis -- ^ @ghc -M@---             | GhcModeEvaluate    -- ^ @ghc -e@- deriving (Show, Eq)--data GhcOptimisation = GhcNoOptimisation             -- ^ @-O0@-                     | GhcNormalOptimisation         -- ^ @-O@-                     | GhcMaximumOptimisation        -- ^ @-O2@-                     | GhcSpecialOptimisation String -- ^ e.g. @-Odph@- deriving (Show, Eq)--data GhcDynLinkMode = GhcStaticOnly       -- ^ @-static@-                    | GhcDynamicOnly      -- ^ @-dynamic@-                    | GhcStaticAndDynamic -- ^ @-static -dynamic-too@- deriving (Show, Eq)--data GhcProfAuto = GhcProfAutoAll       -- ^ @-fprof-auto@-                 | GhcProfAutoToplevel  -- ^ @-fprof-auto-top@-                 | GhcProfAutoExported  -- ^ @-fprof-auto-exported@- deriving (Show, Eq)--runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> Platform  -> GhcOptions-       -> IO ()-runGHC verbosity ghcProg comp platform opts = do-  runProgramInvocation verbosity (ghcInvocation ghcProg comp platform opts)---ghcInvocation :: ConfiguredProgram -> Compiler -> Platform -> GhcOptions-              -> ProgramInvocation-ghcInvocation prog comp platform opts =-    (programInvocation prog (renderGhcOptions comp platform opts)) {-        progInvokePathEnv = fromNubListR (ghcOptExtraPath opts)-    }--renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String]-renderGhcOptions comp _platform@(Platform _arch os) opts-  | compilerFlavor comp `notElem` [GHC, GHCJS] =-    error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "-    ++ "compiler flavor must be 'GHC' or 'GHCJS'!"-  | otherwise =-  concat-  [ case flagToMaybe (ghcOptMode opts) of-       Nothing                 -> []-       Just GhcModeCompile     -> ["-c"]-       Just GhcModeLink        -> []-       Just GhcModeMake        -> ["--make"]-       Just GhcModeInteractive -> ["--interactive"]-       Just GhcModeAbiHash     -> ["--abi-hash"]---     Just GhcModeDepAnalysis -> ["-M"]---     Just GhcModeEvaluate    -> ["-e", expr]--  , ghcOptExtraDefault opts--  , [ "-no-link" | flagBool ghcOptNoLink ]--  ----------------  -- Misc flags--  , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts))--  , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal ]--  -----------------  -- Compilation--  , case flagToMaybe (ghcOptOptimisation opts) of-      Nothing                         -> []-      Just GhcNoOptimisation          -> ["-O0"]-      Just GhcNormalOptimisation      -> ["-O"]-      Just GhcMaximumOptimisation     -> ["-O2"]-      Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph--  , case flagToMaybe (ghcOptDebugInfo opts) of-      Nothing                                -> []-      Just NoDebugInfo                       -> []-      Just MinimalDebugInfo                  -> ["-g1"]-      Just NormalDebugInfo                   -> ["-g2"]-      Just MaximalDebugInfo                  -> ["-g3"]--  , [ "-prof" | flagBool ghcOptProfilingMode ]--  , case flagToMaybe (ghcOptProfilingAuto opts) of-      _ | not (flagBool ghcOptProfilingMode)-                                -> []-      Nothing                   -> []-      Just GhcProfAutoAll-        | flagProfAuto implInfo -> ["-fprof-auto"]-        | otherwise             -> ["-auto-all"] -- not the same, but close-      Just GhcProfAutoToplevel-        | flagProfAuto implInfo -> ["-fprof-auto-top"]-        | otherwise             -> ["-auto-all"]-      Just GhcProfAutoExported-        | flagProfAuto implInfo -> ["-fprof-auto-exported"]-        | otherwise             -> ["-auto"]--  , [ "-split-sections" | flagBool ghcOptSplitSections ]-  , [ "-split-objs" | flagBool ghcOptSplitObjs ]--  , case flagToMaybe (ghcOptHPCDir opts) of-      Nothing -> []-      Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir]--  , if parmakeSupported comp-    then case ghcOptNumJobs opts of-      NoFlag  -> []-      Flag n  -> ["-j" ++ maybe "" show n]-    else []--  ---------------------  -- Creating libraries--  , [ "-staticlib" | flagBool ghcOptStaticLib ]-  , [ "-shared"    | flagBool ghcOptShared    ]-  , case flagToMaybe (ghcOptDynLinkMode opts) of-      Nothing                  -> []-      Just GhcStaticOnly       -> ["-static"]-      Just GhcDynamicOnly      -> ["-dynamic"]-      Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"]-  , [ "-fPIC"    | flagBool ghcOptFPic ]--  , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ]--  -------------------------  -- Redirecting outputs--  , concat [ ["-osuf",    suf] | suf <- flag ghcOptObjSuffix ]-  , concat [ ["-hisuf",   suf] | suf <- flag ghcOptHiSuffix  ]-  , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ]-  , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix  ]-  , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir ]-  , concat [ ["-odir",    dir] | dir <- flag ghcOptObjDir ]-  , concat [ ["-hidir",   dir] | dir <- flag ghcOptHiDir  ]-  , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir ]--  ------------------------  -- Source search path--  , [ "-i"        | flagBool ghcOptSourcePathClear ]-  , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ]--  ----------------------  ---------------------  -- CPP, C, and C++ stuff--  , [ "-I"    ++ dir | dir <- flags ghcOptCppIncludePath ]-  , [ "-optP" ++ opt | opt <- ghcOptCppOptions opts]-  , concat [ [ "-optP-include", "-optP" ++ inc]-           | inc <- flags ghcOptCppIncludes ]-  , [ "-optc" ++ opt | opt <- ghcOptCcOptions opts]-  , -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc-    let cxxflag = case compilerCompatVersion GHC comp of-                Just v | v >= mkVersion [8, 10] -> "-optcxx"-                _ -> "-optc"-    in [ cxxflag ++ opt | opt <- ghcOptCxxOptions opts]-  , [ "-opta" ++ opt | opt <- ghcOptAsmOptions opts]--  ------------------  -- Linker stuff--  , [ "-optl" ++ opt | opt <- ghcOptLinkOptions opts]-  , ["-l" ++ lib     | lib <- ghcOptLinkLibs opts]-  , ["-L" ++ dir     | dir <- flags ghcOptLinkLibPath ]-  , if isOSX-    then concat [ ["-framework", fmwk]-                | fmwk <- flags ghcOptLinkFrameworks ]-    else []-  , if isOSX-    then concat [ ["-framework-path", path]-                | path <- flags ghcOptLinkFrameworkDirs ]-    else []-  , [ "-no-hs-main"  | flagBool ghcOptLinkNoHsMain ]-  , [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ]-  , concat [ [ "-optl-Wl,-rpath," ++ dir]-           | dir <- flags ghcOptRPaths ]-  , [ modDefFile | modDefFile <- flags ghcOptLinkModDefFiles ]--  --------------  -- Packages--  , concat [ [ case () of-                _ | unitIdSupported comp     -> "-this-unit-id"-                  | packageKeySupported comp -> "-this-package-key"-                  | otherwise                -> "-package-name"-             , this_arg ]-             | this_arg <- flag ghcOptThisUnitId ]--  , concat [ ["-this-component-id", prettyShow this_cid ]-           | this_cid <- flag ghcOptThisComponentId ]--  , if null (ghcOptInstantiatedWith opts)-        then []-        else "-instantiated-with"-             : intercalate "," (map (\(n,m) -> prettyShow n ++ "="-                                            ++ prettyShow m)-                                    (ghcOptInstantiatedWith opts))-             : []--  , concat [ ["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode ]--  , [ "-hide-all-packages"     | flagBool ghcOptHideAllPackages ]-  , [ "-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules ]-  , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ]--  , packageDbArgs implInfo (ghcOptPackageDBs opts)--  , concat $ let space "" = ""-                 space xs = ' ' : xs-             in [ ["-package-id", prettyShow ipkgid ++ space (prettyShow rns)]-                | (ipkgid,rns) <- flags ghcOptPackages ]--  -----------------------------  -- Language and extensions--  , if supportsHaskell2010 implInfo-    then [ "-X" ++ prettyShow lang | lang <- flag ghcOptLanguage ]-    else []--  , [ ext'-    | ext  <- flags ghcOptExtensions-    , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of-        Just (Just arg) -> [arg]-        Just Nothing    -> []-        Nothing         ->-            error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "-                  ++ prettyShow ext ++ " not present in ghcOptExtensionMap."-    ]--  -----------------  -- GHCi--  , concat [ [ "-ghci-script", script ] | script <- ghcOptGHCiScripts opts-                                        , flagGhciScript implInfo ]--  ----------------  -- Inputs--  -- Specify the input file(s) first, so that in ghci the `main-is` module is-  -- in scope instead of the first module defined in `other-modules`.-  , flags ghcOptInputFiles-  , [ prettyShow modu | modu <- flags ghcOptInputModules ]--  , concat [ [ "-o",    out] | out <- flag ghcOptOutputFile ]-  , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ]--  ----------------  -- Extra--  , ghcOptExtra opts--  ]---  where-    implInfo     = getImplInfo comp-    isOSX        = os == OSX-    flag     flg = flagToList (flg opts)-    flags    flg = fromNubListR . flg $ opts-    flagBool flg = fromFlagOrDefault False (flg opts)--verbosityOpts :: Verbosity -> [String]-verbosityOpts verbosity-  | verbosity >= deafening = ["-v"]-  | verbosity >= normal    = []-  | otherwise              = ["-w", "-v0"]----- | GHC <7.6 uses '-package-conf' instead of '-package-db'.-packageDbArgsConf :: PackageDBStack -> [String]-packageDbArgsConf dbstack = case dbstack of-  (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs-  (GlobalPackageDB:dbs)               -> ("-no-user-package-conf")-                                       : concatMap specific dbs-  _ -> ierror-  where-    specific (SpecificPackageDB db) = [ "-package-conf", db ]-    specific _                      = ierror-    ierror = error $ "internal error: unexpected package db stack: "-                  ++ show dbstack---- | GHC >= 7.6 uses the '-package-db' flag. See--- https://gitlab.haskell.org/ghc/ghc/-/issues/5977.-packageDbArgsDb :: PackageDBStack -> [String]--- special cases to make arguments prettier in common scenarios-packageDbArgsDb dbstack = case dbstack of-  (GlobalPackageDB:UserPackageDB:dbs)-    | all isSpecific dbs              -> concatMap single dbs-  (GlobalPackageDB:dbs)-    | all isSpecific dbs              -> "-no-user-package-db"-                                       : concatMap single dbs-  dbs                                 -> "-clear-package-db"-                                       : concatMap single dbs- where-   single (SpecificPackageDB db) = [ "-package-db", db ]-   single GlobalPackageDB        = [ "-global-package-db" ]-   single UserPackageDB          = [ "-user-package-db" ]-   isSpecific (SpecificPackageDB _) = True-   isSpecific _                     = False--packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String]-packageDbArgs implInfo-  | flagPackageConf implInfo = packageDbArgsConf-  | otherwise                = packageDbArgsDb+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Distribution.Simple.Program.GHC+  ( GhcOptions (..)+  , GhcMode (..)+  , GhcOptimisation (..)+  , GhcDynLinkMode (..)+  , GhcProfAuto (..)+  , ghcInvocation+  , renderGhcOptions+  , runGHC+  , runGHCWithResponseFile+  , runReplProgram+  , packageDbArgsDb+  , normaliseGhcArgs+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Backpack+import Distribution.Compat.Semigroup (First' (..), Last' (..), Option' (..))+import Distribution.ModuleName+import Distribution.PackageDescription+import Distribution.Pretty+import Distribution.Simple.Compiler+import Distribution.Simple.Flag+import Distribution.Simple.GHC.ImplInfo+import Distribution.Simple.Program.Find (getExtraPathEnv)+import Distribution.Simple.Program.ResponseFile+import Distribution.Simple.Program.Run+import Distribution.Simple.Program.Types+import Distribution.Simple.Utils (TempFileOptions, infoNoWrap)+import Distribution.System+import Distribution.Types.ComponentId+import Distribution.Types.ParStrat+import Distribution.Utils.NubList+import Distribution.Utils.Path+import Distribution.Verbosity+import Distribution.Version++import GHC.IO.Encoding (TextEncoding)+import Language.Haskell.Extension++import Data.List (stripPrefix)+import qualified Data.Map as Map+import Data.Monoid (All (..), Any (..), Endo (..))+import qualified Data.Set as Set+import qualified System.Process as Process++normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String]+normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs+  | ghcVersion `withinRange` supportedGHCVersions =+      argumentFilters . filter simpleFilters . filterRtsArgs $ ghcArgs+  where+    supportedGHCVersions :: VersionRange+    supportedGHCVersions = orLaterVersion (mkVersion [8, 0])+    -- we (weakly) support unknown future GHC versions for the purpose+    -- of filtering GHC arguments++    from :: Monoid m => [Int] -> m -> m+    from version flags+      | ghcVersion `withinRange` orLaterVersion (mkVersion version) = flags+      | otherwise = mempty++    to :: Monoid m => [Int] -> m -> m+    to version flags+      | ghcVersion `withinRange` earlierVersion (mkVersion version) = flags+      | otherwise = mempty++    checkGhcFlags :: forall m. Monoid m => ([String] -> m) -> m+    checkGhcFlags fun =+      mconcat+        [ fun ghcArgs+        , checkComponentFlags libBuildInfo pkgLibs+        , checkComponentFlags buildInfo executables+        , checkComponentFlags testBuildInfo testSuites+        , checkComponentFlags benchmarkBuildInfo benchmarks+        ]+      where+        pkgLibs = maybeToList library ++ subLibraries++        checkComponentFlags :: (a -> BuildInfo) -> [a] -> m+        checkComponentFlags getInfo = foldMap (checkComponent . getInfo)+          where+            checkComponent :: BuildInfo -> m+            checkComponent = foldMap fun . filterGhcOptions . allGhcOptions++            allGhcOptions :: BuildInfo -> [(CompilerFlavor, [String])]+            allGhcOptions =+              foldMap+                (perCompilerFlavorToList .)+                [options, profOptions, sharedOptions, staticOptions]++            filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]]+            filterGhcOptions l = [opts | (GHC, opts) <- l]++    safeToFilterWarnings :: Bool+    safeToFilterWarnings = getAll $ checkGhcFlags checkWarnings+      where+        checkWarnings :: [String] -> All+        checkWarnings = All . Set.null . foldr alter Set.empty++        alter :: String -> Set String -> Set String+        alter flag =+          appEndo $+            mconcat+              [ \s -> Endo $ if s == "-Werror" then Set.insert s else id+              , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id+              , \s ->+                  from [8, 6] . Endo $+                    if s == "-Werror=compat"+                      then Set.union compatWarningSet+                      else id+              , \s ->+                  from [8, 6] . Endo $+                    if s == "-Wno-error=compat"+                      then (`Set.difference` compatWarningSet)+                      else id+              , \s ->+                  from [8, 6] . Endo $+                    if s == "-Wwarn=compat"+                      then (`Set.difference` compatWarningSet)+                      else id+              , from [8, 4] $ markFlag "-Werror=" Set.insert+              , from [8, 4] $ markFlag "-Wwarn=" Set.delete+              , from [8, 4] $ markFlag "-Wno-error=" Set.delete+              ]+              flag++        markFlag+          :: String+          -> (String -> Set String -> Set String)+          -> String+          -> Endo (Set String)+        markFlag name update flag = Endo $ case stripPrefix name flag of+          Just rest | not (null rest) && rest /= "compat" -> update rest+          _ -> id++    flagArgumentFilter :: [String] -> [String] -> [String]+    flagArgumentFilter flags = go+      where+        makeFilter :: String -> String -> Option' (First' ([String] -> [String]))+        makeFilter flag arg = Option' $ First' . filterRest <$> stripPrefix flag arg+          where+            filterRest leftOver = case dropEq leftOver of+              [] -> drop 1+              _ -> id++        checkFilter :: String -> Maybe ([String] -> [String])+        checkFilter = fmap getFirst' . getOption' . foldMap makeFilter flags++        go :: [String] -> [String]+        go [] = []+        go (arg : args) = case checkFilter arg of+          Just f -> go (f args)+          Nothing -> arg : go args++    argumentFilters :: [String] -> [String]+    argumentFilters =+      flagArgumentFilter+        ["-ghci-script", "-H", "-interactive-print"]++    -- \| Remove RTS arguments from a list.+    filterRtsArgs :: [String] -> [String]+    filterRtsArgs = snd . splitRTSArgs++    simpleFilters :: String -> Bool+    simpleFilters =+      not+        . getAny+        . mconcat+          [ flagIn simpleFlags+          , Any . isPrefixOf "-ddump-"+          , Any . isPrefixOf "-dsuppress-"+          , Any . isPrefixOf "-dno-suppress-"+          , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"]+          , flagIn . invertibleFlagSet "-f" . mconcat $+              [+                [ "reverse-errors"+                , "warn-unused-binds"+                , "break-on-error"+                , "break-on-exception"+                , "print-bind-result"+                , "print-bind-contents"+                , "print-evld-with-show"+                , "implicit-import-qualified"+                , "error-spans"+                ]+              , from+                  [7, 8]+                  [ "print-explicit-foralls" -- maybe also earlier, but GHC-7.6 doesn't have --show-options+                  , "print-explicit-kinds"+                  ]+              , from+                  [8, 0]+                  [ "print-explicit-coercions"+                  , "print-explicit-runtime-reps"+                  , "print-equality-relations"+                  , "print-unicode-syntax"+                  , "print-expanded-synonyms"+                  , "print-potential-instances"+                  , "print-typechecker-elaboration"+                  ]+              , from+                  [8, 2]+                  [ "diagnostics-show-caret"+                  , "local-ghci-history"+                  , "show-warning-groups"+                  , "hide-source-paths"+                  , "show-hole-constraints"+                  ]+              , from [8, 4] ["show-loaded-modules"]+              , from [8, 6] ["ghci-leak-check", "no-it"]+              , from+                  [8, 10]+                  [ "defer-diagnostics" -- affects printing of diagnostics+                  , "keep-going" -- try harder, the build will still fail if it's erroneous+                  , "print-axiom-incomps" -- print more debug info for closed type families+                  ]+              , from+                  [9, 2]+                  [ "family-application-cache"+                  ]+              , from+                  [9, 6]+                  [ "print-redundant-promotion-ticks"+                  , "show-error-context"+                  ]+              , from+                  [9, 8]+                  [ "unoptimized-core-for-interpreter"+                  ]+              , from+                  [9, 10]+                  [ "diagnostics-as-json"+                  , "print-error-index-links"+                  , "break-points"+                  ]+              ]+          , flagIn $ invertibleFlagSet "-d" ["ppr-case-as-let", "ppr-ticks"]+          , isOptIntFlag+          , isIntFlag+          , if safeToFilterWarnings+              then isWarning <> (Any . ("-w" ==))+              else mempty+          , from [8, 6] $+              if safeToFilterHoles+                then isTypedHoleFlag+                else mempty+          ]++    flagIn :: Set String -> String -> Any+    flagIn set flag = Any $ Set.member flag set++    isWarning :: String -> Any+    isWarning =+      mconcat $+        map+          ((Any .) . isPrefixOf)+          ["-fwarn-", "-fno-warn-", "-W", "-Wno-"]++    simpleFlags :: Set String+    simpleFlags =+      Set.fromList . mconcat $+        [+          [ "-n"+          , "-#include"+          , "-Rghc-timing"+          , "-dstg-stats"+          , "-dth-dec-file"+          , "-dsource-stats"+          , "-dverbose-core2core"+          , "-dverbose-stg2stg"+          , "-dcore-lint"+          , "-dstg-lint"+          , "-dcmm-lint"+          , "-dasm-lint"+          , "-dannot-lint"+          , "-dshow-passes"+          , "-dfaststring-stats"+          , "-fno-max-relevant-binds"+          , "-recomp"+          , "-no-recomp"+          , "-fforce-recomp"+          , "-fno-force-recomp"+          ]+        , from+            [8, 2]+            [ "-fno-max-errors"+            , "-fdiagnostics-color=auto"+            , "-fdiagnostics-color=always"+            , "-fdiagnostics-color=never"+            , "-dppr-debug"+            , "-dno-debug-output"+            ]+        , from [8, 4] ["-ddebug-output"]+        , from [8, 4] $ to [8, 6] ["-fno-max-valid-substitutions"]+        , from [8, 6] ["-dhex-word-literals"]+        , from [8, 8] ["-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits"]+        , from [9, 0] ["-dlinear-core-lint"]+        , from [9, 10] ["-dipe-stats"]+        ]++    isOptIntFlag :: String -> Any+    isOptIntFlag = mconcat . map (dropIntFlag True) $ ["-v", "-j"]++    isIntFlag :: String -> Any+    isIntFlag =+      mconcat . map (dropIntFlag False) . mconcat $+        [+          [ "-fmax-relevant-binds"+          , "-ddpr-user-length"+          , "-ddpr-cols"+          , "-dtrace-level"+          , "-fghci-hist-size"+          , "-dinitial-unique"+          , "-dunique-increment"+          ]+        , from [8, 2] ["-fmax-uncovered-patterns", "-fmax-errors"]+        , from [8, 4] $ to [8, 6] ["-fmax-valid-substitutions"]+        , from [9, 12] ["-fmax-forced-spec-args", "-fwrite-if-compression"]+        ]++    dropIntFlag :: Bool -> String -> String -> Any+    dropIntFlag isOpt flag input = Any $ case stripPrefix flag input of+      Nothing -> False+      Just rest+        | isOpt && null rest -> True+        | otherwise -> case parseInt rest of+            Just _ -> True+            Nothing -> False+      where+        parseInt :: String -> Maybe Int+        parseInt = readMaybe . dropEq++    dropEq :: String -> String+    dropEq ('=' : s) = s+    dropEq s = s++    invertibleFlagSet :: String -> [String] -> Set String+    invertibleFlagSet prefix flagNames =+      Set.fromList $ (++) <$> [prefix, prefix ++ "no-"] <*> flagNames++    compatWarningSet :: Set String+    compatWarningSet =+      Set.fromList $+        mconcat+          [ from+              [8, 6]+              [ "missing-monadfail-instances"+              , "semigroup"+              , "noncanonical-monoid-instances"+              , "implicit-kind-vars"+              ]+          ]++    safeToFilterHoles :: Bool+    safeToFilterHoles =+      getAll . checkGhcFlags $+        All . fromMaybe True . fmap getLast' . getOption' . 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++    isTypedHoleFlag :: String -> Any+    isTypedHoleFlag =+      mconcat+        [ flagIn . invertibleFlagSet "-f" $+            [ "show-hole-constraints"+            , "show-valid-substitutions"+            , "show-valid-hole-fits"+            , "sort-valid-hole-fits"+            , "sort-by-size-hole-fits"+            , "sort-by-subsumption-hole-fits"+            , "abstract-refinement-hole-fits"+            , "show-provenance-of-hole-fits"+            , "show-hole-matches-of-hole-fits"+            , "show-type-of-hole-fits"+            , "show-type-app-of-hole-fits"+            , "show-type-app-vars-of-hole-fits"+            , "unclutter-valid-hole-fits"+            ]+        , flagIn . Set.fromList $+            [ "-fno-max-valid-hole-fits"+            , "-fno-max-refinement-hole-fits"+            , "-fno-refinement-level-hole-fits"+            ]+        , mconcat . map (dropIntFlag False) $+            [ "-fmax-valid-hole-fits"+            , "-fmax-refinement-hole-fits"+            , "-frefinement-level-hole-fits"+            ]+        ]+normaliseGhcArgs _ _ args = args++-- | A structured set of GHC options/flags+--+-- Note that options containing lists fall into two categories:+--+--  * options that can be safely deduplicated, e.g. input modules or+--    enabled extensions;+--  * options that cannot be deduplicated in general without changing+--    semantics, e.g. extra ghc options or linking options.+data GhcOptions = GhcOptions+  { ghcOptMode :: Flag GhcMode+  -- ^ The major mode for the ghc invocation.+  , ghcOptExtra :: [String]+  -- ^ Any extra options to pass directly to ghc. These go at the end and hence+  -- override other stuff.+  , ghcOptExtraDefault :: [String]+  -- ^ Extra default flags to pass directly to ghc. These go at the beginning+  -- and so can be overridden by other stuff.+  , -----------------------+    -- Inputs and outputs++    ghcOptInputFiles :: NubListR (SymbolicPath Pkg File)+  -- ^ The main input files; could be .hs, .hi, .c, .o, depending on mode.+  , ghcOptInputScripts :: NubListR (SymbolicPath Pkg File)+  -- ^ Script files with irregular extensions that need -x hs.+  , ghcOptInputModules :: NubListR ModuleName+  -- ^ The names of input Haskell modules, mainly for @--make@ mode.+  , ghcOptOutputFile :: Flag (SymbolicPath Pkg File)+  -- ^ Location for output file; the @ghc -o@ flag.+  , ghcOptOutputDynFile :: Flag FilePath+  -- ^ Location for dynamic output file in 'GhcStaticAndDynamic' mode;+  -- the @ghc -dyno@ flag.+  , ghcOptSourcePathClear :: Flag Bool+  -- ^ Start with an empty search path for Haskell source files;+  -- the @ghc -i@ flag (@-i@ on its own with no path argument).+  , ghcOptSourcePath :: NubListR (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++    ghcOptThisUnitId :: Flag String+  -- ^ The unit ID the modules will belong to; the @ghc -this-unit-id@+  -- flag (or @-this-package-key@ or @-package-name@ on older+  -- versions of GHC).  This is a 'String' because we assume you've+  -- already figured out what the correct format for this string is+  -- (we need to handle backwards compatibility.)+  , ghcOptThisComponentId :: Flag ComponentId+  -- ^ GHC doesn't make any assumptions about the format of+  -- definite unit ids, so when we are instantiating a package it+  -- needs to be told explicitly what the component being instantiated+  -- is.  This only gets set when 'ghcOptInstantiatedWith' is non-empty+  , ghcOptInstantiatedWith :: [(ModuleName, OpenModule)]+  -- ^ How the requirements of the package being compiled are to+  -- be filled.  When typechecking an indefinite package, the 'OpenModule'+  -- is always a 'OpenModuleVar'; otherwise, it specifies the installed module+  -- that instantiates a package.+  , ghcOptNoCode :: Flag Bool+  -- ^ No code? (But we turn on interface writing+  , ghcOptPackageDBs :: PackageDBStack+  -- ^ GHC package databases to use, the @ghc -package-conf@ flag.+  , ghcOptPackages+      :: NubListR (OpenUnitId, ModuleRenaming)+  -- ^ The GHC packages to bring into scope when compiling,+  -- the @ghc -package-id@ flags.+  , ghcOptHideAllPackages :: Flag Bool+  -- ^ Start with a clean package set; the @ghc -hide-all-packages@ flag+  , ghcOptWarnMissingHomeModules :: Flag Bool+  -- ^ Warn about modules, not listed in command line+  , ghcOptNoAutoLinkPackages :: Flag Bool+  -- ^ Don't automatically link in Haskell98 etc; the @ghc+  -- -no-auto-link-packages@ flag.+  , -----------------+    -- Linker stuff++    ghcOptLinkLibs :: [FilePath]+  -- ^ Names of libraries to link in; the @ghc -l@ flag.+  , ghcOptLinkLibPath :: NubListR (SymbolicPath Pkg (Dir Lib))+  -- ^ Search path for libraries to link in; the @ghc -L@ flag.+  , ghcOptLinkOptions :: [String]+  -- ^ Options to pass through to the linker; the @ghc -optl@ flag.+  , ghcOptLinkFrameworks :: NubListR String+  -- ^ OSX only: frameworks to link in; the @ghc -framework@ flag.+  , ghcOptLinkFrameworkDirs :: NubListR (SymbolicPath Pkg (Dir Framework))+  -- ^ OSX only: Search path for frameworks to link in; the+  -- @ghc -framework-path@ flag.+  , ghcOptLinkRts :: Flag Bool+  -- ^ Instruct GHC to link against @libHSrts@ when producing a shared library.+  , ghcOptNoLink :: Flag Bool+  -- ^ Don't do the link step, useful in make mode; the @ghc -no-link@ flag.+  , ghcOptLinkNoHsMain :: Flag Bool+  -- ^ Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@+  -- flag.+  , ghcOptLinkModDefFiles :: NubListR FilePath+  -- ^ Module definition files (Windows specific)+  , --------------------+    -- C and CPP stuff++    ghcOptCcOptions :: [String]+  -- ^ Options to pass through to the C compiler; the @ghc -optc@ flag.+  , ghcOptCxxOptions :: [String]+  -- ^ Options to pass through to the C++ compiler.+  , ghcOptAsmOptions :: [String]+  -- ^ Options to pass through to the Assembler.+  , ghcOptCppOptions :: [String]+  -- ^ Options to pass through to CPP; the @ghc -optP@ flag.+  , 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)+  -- ^ Extra header files to include at CPP stage; the @ghc -optP-include@ flag.+  , ghcOptFfiIncludes :: NubListR FilePath+  -- ^ Extra header files to include for old-style FFI; the @ghc -#include@ flag.+  , ghcOptCcProgram :: Flag FilePath+  -- ^ Program to use for the C and C++ compiler; the @ghc -pgmc@ flag.+  , ----------------------------+    -- Language and extensions++    ghcOptLanguage :: Flag Language+  -- ^ The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag.+  , ghcOptExtensions :: NubListR Extension+  -- ^ The language extensions; the @ghc -X@ flag.+  , ghcOptExtensionMap :: Map Extension (Maybe CompilerFlag)+  -- ^ A GHC version-dependent mapping of extensions to flags. This must be+  -- set to be able to make use of the 'ghcOptExtensions'.+  , ----------------+    -- Compilation++    ghcOptOptimisation :: Flag GhcOptimisation+  -- ^ What optimisation level to use; the @ghc -O@ flag.+  , ghcOptDebugInfo :: Flag DebugInfoLevel+  -- ^ Emit debug info; the @ghc -g@ flag.+  , ghcOptProfilingMode :: Flag Bool+  -- ^ Compile in profiling mode; the @ghc -prof@ flag.+  , ghcOptProfilingAuto :: Flag GhcProfAuto+  -- ^ Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags.+  , ghcOptSplitSections :: Flag Bool+  -- ^ Use the \"split sections\" feature; the @ghc -split-sections@ flag.+  , ghcOptSplitObjs :: Flag Bool+  -- ^ Use the \"split object files\" feature; the @ghc -split-objs@ flag.+  , ghcOptNumJobs :: Flag ParStrat+  -- ^ Run N jobs simultaneously (if possible).+  , ghcOptHPCDir :: Flag (SymbolicPath Pkg (Dir Mix))+  -- ^ Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags.+  , ----------------+    -- GHCi++    ghcOptGHCiScripts :: [FilePath]+  -- ^ Extra GHCi startup scripts; the @-ghci-script@ flag+  , ------------------------+    -- Redirecting outputs++    ghcOptHiSuffix :: Flag String+  , ghcOptObjSuffix :: Flag String+  , ghcOptDynHiSuffix :: Flag String+  -- ^ only in 'GhcStaticAndDynamic' mode+  , ghcOptDynObjSuffix :: Flag String+  -- ^ only in 'GhcStaticAndDynamic' mode+  , ghcOptHiDir :: Flag (SymbolicPath Pkg (Dir Artifacts))+  , ghcOptHieDir :: Flag (SymbolicPath Pkg (Dir Artifacts))+  , ghcOptObjDir :: Flag (SymbolicPath Pkg (Dir Artifacts))+  , ghcOptOutputDir :: Flag (SymbolicPath Pkg (Dir Artifacts))+  , ghcOptStubDir :: Flag (SymbolicPath Pkg (Dir Artifacts))+  , --------------------+    -- Creating libraries++    ghcOptDynLinkMode :: Flag GhcDynLinkMode+  , ghcOptStaticLib :: Flag Bool+  , ghcOptShared :: Flag Bool+  , ghcOptFPic :: Flag Bool+  , ghcOptDylibName :: Flag String+  , ghcOptRPaths :: NubListR FilePath+  , ---------------+    -- Misc flags++    ghcOptVerbosity :: Flag Verbosity+  -- ^ Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag.+  , ghcOptExtraPath :: NubListR (SymbolicPath Pkg (Dir Build))+  -- ^ Put the extra folders in the PATH environment variable we invoke+  -- GHC with+  , ghcOptCabal :: Flag Bool+  -- ^ Let GHC know that it is Cabal that's calling it.+  -- Modifies some of the GHC error messages.+  }+  deriving (Show, Generic)++data GhcMode+  = -- | @ghc -c@+    GhcModeCompile+  | -- | @ghc@+    GhcModeLink+  | -- | @ghc --make@+    GhcModeMake+  | -- | @ghci@ \/ @ghc --interactive@+    GhcModeInteractive+  | -- | @ghc --abi-hash@+    --             | GhcModeDepAnalysis -- ^ @ghc -M@+    --             | GhcModeEvaluate    -- ^ @ghc -e@+    GhcModeAbiHash+  deriving (Show, Eq)++data GhcOptimisation+  = -- | @-O0@+    GhcNoOptimisation+  | -- | @-O@+    GhcNormalOptimisation+  | -- | @-O2@+    GhcMaximumOptimisation+  | -- | e.g. @-Odph@+    GhcSpecialOptimisation String+  deriving (Show, Eq)++data GhcDynLinkMode+  = -- | @-static@+    GhcStaticOnly+  | -- | @-dynamic@+    GhcDynamicOnly+  | -- | @-static -dynamic-too@+    GhcStaticAndDynamic+  deriving (Show, Eq)++data GhcProfAuto+  = -- | @-fprof-auto@+    GhcProfAutoAll+  | -- | @-fprof-auto-top@+    GhcProfAutoToplevel+  | -- | @-fprof-auto-exported@+    GhcProfAutoExported+  | -- | @-fprof-late+    GhcProfLate+  deriving (Show, Eq)++runGHC+  :: Verbosity+  -> ConfiguredProgram+  -> Compiler+  -> Platform+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> GhcOptions+  -> IO ()+runGHC verbosity ghcProg comp platform mbWorkDir opts = do+  runProgramInvocation verbosity+    =<< ghcInvocation verbosity ghcProg comp platform mbWorkDir opts++runGHCWithResponseFile+  :: FilePath+  -> Maybe TextEncoding+  -> TempFileOptions+  -> Verbosity+  -> ConfiguredProgram+  -> Compiler+  -> Platform+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> GhcOptions+  -> IO ()+runGHCWithResponseFile fileNameTemplate encoding tempFileOptions verbosity ghcProg comp platform maybeWorkDir opts = do+  invocation <- ghcInvocation verbosity ghcProg comp platform maybeWorkDir opts++  let compilerSupportsResponseFiles =+        case compilerCompatVersion GHC comp of+          -- GHC 9.4 is the first version which supports response files.+          Just version -> version >= mkVersion [9, 4]+          Nothing -> False++      args = progInvokeArgs invocation++  if not compilerSupportsResponseFiles+    then runProgramInvocation verbosity invocation+    else do+      let (rtsArgs, otherArgs) = splitRTSArgs args++      withResponseFile+        verbosity+        tempFileOptions+        fileNameTemplate+        encoding+        otherArgs+        $ \responseFile -> do+          let newInvocation =+                invocation{progInvokeArgs = ('@' : responseFile) : rtsArgs}++          infoNoWrap verbosity $+            "GHC response file arguments: "+              <> case otherArgs of+                [] -> ""+                arg : args' -> Process.showCommandForUser arg args'++          runProgramInvocation verbosity newInvocation++-- Note [Make --interactive the first argument to GHC]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The ghc argument @--interactive@ needs to be the first argument to the+-- ghc invocation, because Haskell Language Server used to rely on this.+-- This was initially changed for Cabal 3.16, but it broke all existing Haskell+-- Language Server prebuilt binaries.+-- To avoid this, we uphold this assumption in Haskell Language Server until the next+-- Cabal release (3.18).+--+-- The solution is to make sure that @--interactive@ is not passed as an argument in+-- the response file that is usually passed to ghc.+-- Instead, we filter out @--interactive@ and always pass it as the first argument,+-- if it exists.+--+-- We plan to remove this Hack in Cabal 3.18.++-- 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 do+        -- in runGHCWithResponseFile "ghci.rsp" Nothing tempFileOptions verbosity replProg comp platform mbWorkDir ghcOpts+        -- See Note [Make --interactive the first argument to GHC]+        -- In Cabal 3.18, restore the line above.+        invocation <- ghcInvocation verbosity replProg comp platform mbWorkDir ghcOpts+        let invocation' =+              let+                argsWithoutInteractive = filter (/= "--interactive") (progInvokeArgs invocation)+               in+                invocation+                  { progInvokeArgs = ["--interactive"] <> argsWithoutInteractive+                  }+        runProgramInvocation verbosity invocation'++ghcInvocation+  :: Verbosity+  -> ConfiguredProgram+  -> Compiler+  -> Platform+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> GhcOptions+  -> IO ProgramInvocation+ghcInvocation verbosity ghcProg comp platform mbWorkDir opts = do+  -- NOTE: GHC is the only program whose path we modify with more values than+  -- the standard @extra-prog-path@, namely the folders of the executables in+  -- the components, see @componentGhcOptions@.+  let envOverrides = programOverrideEnv ghcProg+  extraPath <-+    getExtraPathEnv verbosity envOverrides $+      map getSymbolicPath $+        fromNubListR $+          ghcOptExtraPath opts+  let ghcProg' = ghcProg{programOverrideEnv = envOverrides ++ extraPath}+  return $+    programInvocationCwd mbWorkDir ghcProg' $+      renderGhcOptions comp platform opts++-- TODO: use the -working-dir GHC flag instead of setting the process+-- working directory, as this improves error messages.++renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String]+renderGhcOptions comp _platform@(Platform _arch os) opts+  | compilerFlavor comp `notElem` [GHC, GHCJS] =+      error $+        "Distribution.Simple.Program.GHC.renderGhcOptions: "+          ++ "compiler flavor must be 'GHC' or 'GHCJS'!"+  | otherwise =+      concat+        [ case flagToMaybe (ghcOptMode opts) of+            Nothing -> []+            Just GhcModeCompile -> ["-c"]+            Just GhcModeLink -> []+            Just GhcModeMake -> ["--make"]+            Just GhcModeInteractive -> ["--interactive"]+            Just GhcModeAbiHash -> ["--abi-hash"]+        , --     Just GhcModeDepAnalysis -> ["-M"]+          --     Just GhcModeEvaluate    -> ["-e", expr]++          ghcOptExtraDefault opts+        , ["-no-link" | flagBool ghcOptNoLink]+        , ["-flink-rts" | flagBool ghcOptLinkRts]+        , ---------------+          -- Misc flags++          maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts))+        , ["-fbuilding-cabal-package" | flagBool ghcOptCabal]+        , ----------------+          -- Compilation++          case flagToMaybe (ghcOptOptimisation opts) of+            Nothing -> []+            Just GhcNoOptimisation -> ["-O0"]+            Just GhcNormalOptimisation -> ["-O"]+            Just GhcMaximumOptimisation -> ["-O2"]+            Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph+        , case flagToMaybe (ghcOptDebugInfo opts) of+            Nothing -> []+            Just NoDebugInfo -> []+            Just MinimalDebugInfo -> ["-g1"]+            Just NormalDebugInfo -> ["-g2"]+            Just MaximalDebugInfo -> ["-g3"]+        , ["-prof" | flagBool ghcOptProfilingMode]+        , case flagToMaybe (ghcOptProfilingAuto opts) of+            _+              | not (flagBool ghcOptProfilingMode) ->+                  []+            Nothing -> []+            Just GhcProfAutoAll+              | flagProfAuto implInfo -> ["-fprof-auto"]+              | otherwise -> ["-auto-all"] -- not the same, but close+            Just GhcProfLate+              | flagProfLate implInfo -> ["-fprof-late"]+              | otherwise -> ["-fprof-auto-top"] -- not the same, not very close, but what we have.+            Just GhcProfAutoToplevel+              | flagProfAuto implInfo -> ["-fprof-auto-top"]+              | otherwise -> ["-auto-all"]+            Just GhcProfAutoExported+              | flagProfAuto implInfo -> ["-fprof-auto-exported"]+              | otherwise -> ["-auto"]+        , ["-split-sections" | flagBool ghcOptSplitSections]+        , case compilerCompatVersion GHC comp of+            -- the -split-objs flag was removed in GHC 9.8+            Just ver | ver >= mkVersion [9, 8] -> []+            _ -> ["-split-objs" | flagBool ghcOptSplitObjs]+        , case flagToMaybe (ghcOptHPCDir opts) of+            Nothing -> []+            Just hpcdir -> ["-fhpc", "-hpcdir", u hpcdir]+        , if parmakeSupported comp+            then case ghcOptNumJobs opts of+              NoFlag -> []+              Flag Serial -> []+              Flag (UseSem name) ->+                if jsemSupported comp+                  then ["-jsem " ++ name]+                  else []+              Flag (NumJobs n) -> ["-j" ++ maybe "" show n]+            else []+        , --------------------+          -- Creating libraries++          ["-staticlib" | flagBool ghcOptStaticLib]+        , ["-shared" | flagBool ghcOptShared]+        , case flagToMaybe (ghcOptDynLinkMode opts) of+            Nothing -> []+            Just GhcStaticOnly -> ["-static"]+            Just GhcDynamicOnly -> ["-dynamic"]+            Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"]+        , ["-fPIC" | flagBool ghcOptFPic]+        , concat [["-dylib-install-name", libname] | libname <- flag ghcOptDylibName]+        , ------------------------+          -- Redirecting outputs++          concat [["-osuf", suf] | suf <- flag ghcOptObjSuffix]+        , concat [["-hisuf", suf] | suf <- flag ghcOptHiSuffix]+        , concat [["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix]+        , concat [["-dynhisuf", suf] | suf <- flag ghcOptDynHiSuffix]+        , concat [["-outputdir", u dir] | dir <- flag ghcOptOutputDir]+        , concat [["-odir", u dir] | dir <- flag ghcOptObjDir]+        , concat [["-hidir", u dir] | dir <- flag ghcOptHiDir]+        , concat [["-hiedir", u dir] | dir <- flag ghcOptHieDir]+        , concat [["-stubdir", u dir] | dir <- flag ghcOptStubDir]+        , -----------------------+          -- Source search path++          ["-i" | flagBool ghcOptSourcePathClear]+        , ["-i" ++ u dir | dir <- flags ghcOptSourcePath]+        , --------------------++          --------------------+          -- CPP, C, and C++ stuff++          ["-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+          let cxxflag = case compilerCompatVersion GHC comp of+                Just v | v >= mkVersion [8, 10] -> "-optcxx"+                _ -> "-optc"+           in [cxxflag ++ opt | opt <- ghcOptCxxOptions opts]+        , ["-opta" ++ opt | opt <- ghcOptAsmOptions opts]+        , concat [["-pgmc", cc] | cc <- flag ghcOptCcProgram]+        , -----------------+          -- Linker stuff++          ["-optl" ++ opt | opt <- ghcOptLinkOptions opts]+        , ["-l" ++ lib | lib <- ghcOptLinkLibs opts]+        , ["-L" ++ u dir | dir <- flags ghcOptLinkLibPath]+        , if isOSX+            then+              concat+                [ ["-framework", fmwk]+                | fmwk <- flags ghcOptLinkFrameworks+                ]+            else []+        , if isOSX+            then+              concat+                [ ["-framework-path", u path]+                | path <- flags ghcOptLinkFrameworkDirs+                ]+            else []+        , ["-no-hs-main" | flagBool ghcOptLinkNoHsMain]+        , ["-dynload deploy" | not (null (flags ghcOptRPaths))]+        , ["-optl-Wl,-rpath," ++ dir | dir <- flags ghcOptRPaths]+        , flags ghcOptLinkModDefFiles+        , -------------+          -- Packages++          concat+            [ [ if+                    | unitIdSupported comp -> "-this-unit-id"+                    | packageKeySupported comp -> "-this-package-key"+                    | otherwise -> "-package-name"+              , this_arg+              ]+            | this_arg <- flag ghcOptThisUnitId+            ]+        , concat+            [ ["-this-component-id", prettyShow this_cid]+            | this_cid <- flag ghcOptThisComponentId+            ]+        , if null (ghcOptInstantiatedWith opts)+            then []+            else+              "-instantiated-with"+                : intercalate+                  ","+                  ( map+                      ( \(n, m) ->+                          prettyShow n+                            ++ "="+                            ++ prettyShow m+                      )+                      (ghcOptInstantiatedWith opts)+                  )+                : []+        , concat [["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode]+        , ["-hide-all-packages" | flagBool ghcOptHideAllPackages]+        , ["-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules]+        , ["-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages]+        , packageDbArgs implInfo (interpretPackageDBStack Nothing (ghcOptPackageDBs opts))+        , concat $+            let space "" = ""+                space xs = ' ' : xs+             in [ ["-package-id", prettyShow ipkgid ++ space (prettyShow rns)]+                | (ipkgid, rns) <- flags ghcOptPackages+                ]+        , ----------------------------+          -- Language and extensions++          if supportsHaskell2010 implInfo+            then ["-X" ++ prettyShow lang | lang <- flag ghcOptLanguage]+            else []+        , [ ext'+          | ext <- flags ghcOptExtensions+          , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of+              Just (Just arg) -> [arg]+              Just Nothing -> []+              Nothing ->+                error $+                  "Distribution.Simple.Program.GHC.renderGhcOptions: "+                    ++ prettyShow ext+                    ++ " not present in ghcOptExtensionMap."+          ]+        , ----------------+          -- GHCi++          concat+            [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts, flagGhciScript implInfo+            ]+        , ---------------+          -- Inputs++          -- Specify the input file(s) first, so that in ghci the `main-is` module is+          -- in scope instead of the first module defined in `other-modules`.+          map u $ flags ghcOptInputFiles+        , concat [["-x", "hs", u script] | script <- flags ghcOptInputScripts]+        , [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++          ghcOptExtra opts+        ]+  where+    -- See Note [Symbolic paths] in Distribution.Utils.Path+    u :: SymbolicPath Pkg to -> FilePath+    u = interpretSymbolicPathCWD+    implInfo = getImplInfo comp+    isOSX = os == OSX+    flag flg = flagToList (flg opts)+    flags flg = fromNubListR . flg $ opts+    flagBool flg = fromFlagOrDefault False (flg opts)++verbosityOpts :: Verbosity -> [String]+verbosityOpts verbosity+  | 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+  (GlobalPackageDB : UserPackageDB : dbs)+    | all isSpecific dbs -> concatMap single dbs+  (GlobalPackageDB : dbs)+    | all isSpecific dbs ->+        "-no-user-package-db"+          : concatMap single dbs+  dbs ->+    "-clear-package-db"+      : concatMap single dbs+  where+    single (SpecificPackageDB db) = ["-package-db", db]+    single GlobalPackageDB = ["-global-package-db"]+    single UserPackageDB = ["-user-package-db"]+    isSpecific (SpecificPackageDB _) = True+    isSpecific _ = False++packageDbArgs :: GhcImplInfo -> 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,9 +1,11 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Program.HcPkg -- Copyright   :  Duncan Coutts 2009, 2013@@ -13,35 +15,34 @@ -- -- This module provides an library interface to the @hc-pkg@ program. -- Currently only GHC and GHCJS have hc-pkg programs.--module Distribution.Simple.Program.HcPkg (-    -- * Types-    HcPkgInfo(..),-    RegisterOptions(..),-    defaultRegisterOptions,+module Distribution.Simple.Program.HcPkg+  ( -- * Types+    HcPkgInfo (..)+  , RegisterOptions (..)+  , defaultRegisterOptions      -- * Actions-    init,-    invoke,-    register,-    unregister,-    recache,-    expose,-    hide,-    dump,-    describe,-    list,+  , init+  , invoke+  , register+  , unregister+  , recache+  , expose+  , hide+  , dump+  , describe+  , list      -- * Program invocations-    initInvocation,-    registerInvocation,-    unregisterInvocation,-    recacheInvocation,-    exposeInvocation,-    hideInvocation,-    dumpInvocation,-    describeInvocation,-    listInvocation,+  , initInvocation+  , registerInvocation+  , unregisterInvocation+  , recacheInvocation+  , exposeInvocation+  , hideInvocation+  , dumpInvocation+  , describeInvocation+  , listInvocation   ) where  import Distribution.Compat.Prelude hiding (init)@@ -51,245 +52,278 @@ import Distribution.Parsec import Distribution.Pretty import Distribution.Simple.Compiler+import Distribution.Simple.Errors import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.Types.ComponentId import Distribution.Types.PackageId import Distribution.Types.UnitId+import Distribution.Utils.Path import Distribution.Verbosity -import Data.List       (stripPrefix)-import System.FilePath as FilePath (isPathSeparator, joinPath, splitDirectories, splitPath, (<.>), (</>))+import Data.List (stripPrefix)+import System.FilePath as FilePath+  ( isPathSeparator+  , joinPath+  , splitDirectories+  , splitPath+  ) -import qualified Data.ByteString       as BS-import qualified Data.ByteString.Lazy  as LBS-import qualified Data.List.NonEmpty    as NE+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List.NonEmpty as NE import qualified System.FilePath.Posix as FilePath.Posix  -- | Information about the features and capabilities of an @hc-pkg@ --   program.--- data HcPkgInfo = HcPkgInfo-  { hcPkgProgram    :: ConfiguredProgram-  , noPkgDbStack    :: Bool -- ^ no package DB stack supported-  , noVerboseFlag   :: Bool -- ^ hc-pkg does not support verbosity flags-  , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db-  , supportsDirDbs  :: Bool -- ^ supports directory style package databases-  , requiresDirDbs  :: Bool -- ^ requires directory style package databases-  , nativeMultiInstance  :: Bool -- ^ supports --enable-multi-instance flag-  , recacheMultiInstance :: Bool -- ^ supports multi-instance via recache-  , suppressFilesCheck   :: Bool -- ^ supports --force-files or equivalent+  { hcPkgProgram :: ConfiguredProgram+  , noPkgDbStack :: Bool+  -- ^ no package DB stack supported+  , noVerboseFlag :: Bool+  -- ^ hc-pkg does not support verbosity flags+  , flagPackageConf :: Bool+  -- ^ use package-conf option instead of package-db+  , supportsDirDbs :: Bool+  -- ^ supports directory style package databases+  , requiresDirDbs :: Bool+  -- ^ requires directory style package databases+  , nativeMultiInstance :: Bool+  -- ^ supports --enable-multi-instance flag+  , recacheMultiInstance :: Bool+  -- ^ supports multi-instance via recache+  , suppressFilesCheck :: Bool+  -- ^ supports --force-files or equivalent   } - -- | Call @hc-pkg@ to initialise a package database at the location {path}. -- -- > hc-pkg init {path}--- init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO () init hpi verbosity preferCompat path-  |  not (supportsDirDbs hpi)- || (not (requiresDirDbs hpi) && preferCompat)-  = writeFile path "[]"--  | otherwise-  = runProgramInvocation verbosity (initInvocation hpi verbosity path)+  | not (supportsDirDbs hpi)+      || (not (requiresDirDbs hpi) && preferCompat) =+      writeFile path "[]"+  | otherwise =+      runProgramInvocation verbosity (initInvocation hpi verbosity path)  -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it.-invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO ()-invoke hpi verbosity dbStack extraArgs =+invoke+  :: HcPkgInfo+  -> Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> PackageDBStack+  -> [String]+  -> IO ()+invoke hpi verbosity mbWorkDir dbStack extraArgs =   runProgramInvocation verbosity invocation   where-    args       = packageDbStackOpts hpi dbStack ++ extraArgs-    invocation = programInvocation (hcPkgProgram hpi) args+    args = packageDbStackOpts hpi dbStack ++ extraArgs+    invocation = programInvocationCwd mbWorkDir (hcPkgProgram hpi) args  -- | Additional variations in the behaviour for 'register'.-data RegisterOptions = RegisterOptions {-       -- | Allows re-registering \/ overwriting an existing package-       registerAllowOverwrite     :: Bool,--       -- | Insist on the ability to register multiple instances of a-       -- single version of a single package. This will fail if the @hc-pkg@-       -- does not support it, see 'nativeMultiInstance' and-       -- 'recacheMultiInstance'.-       registerMultiInstance      :: Bool,--       -- | Require that no checks are performed on the existence of package-       -- files mentioned in the registration info. This must be used if-       -- registering prior to putting the files in their final place. This will-       -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'.-       registerSuppressFilesCheck :: Bool-     }+data RegisterOptions = RegisterOptions+  { registerAllowOverwrite :: Bool+  -- ^ Allows re-registering \/ overwriting an existing package+  , registerMultiInstance :: Bool+  -- ^ Insist on the ability to register multiple instances of a+  -- single version of a single package. This will fail if the @hc-pkg@+  -- does not support it, see 'nativeMultiInstance' and+  -- 'recacheMultiInstance'.+  , registerSuppressFilesCheck :: Bool+  -- ^ Require that no checks are performed on the existence of package+  -- files mentioned in the registration info. This must be used if+  -- registering prior to putting the files in their final place. This will+  -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'.+  }  -- | Defaults are @True@, @False@ and @False@ defaultRegisterOptions :: RegisterOptions-defaultRegisterOptions = RegisterOptions {-    registerAllowOverwrite     = True,-    registerMultiInstance      = False,-    registerSuppressFilesCheck = False-  }+defaultRegisterOptions =+  RegisterOptions+    { registerAllowOverwrite = True+    , registerMultiInstance = False+    , registerSuppressFilesCheck = False+    }  -- | Call @hc-pkg@ to register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-db]----register :: HcPkgInfo -> Verbosity -> PackageDBStack-         -> InstalledPackageInfo-         -> RegisterOptions-         -> IO ()-register hpi verbosity packagedbs pkgInfo registerOptions+register+  :: HcPkgInfo+  -> Verbosity+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBStackS from+  -> InstalledPackageInfo+  -> RegisterOptions+  -> IO ()+register hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions   | registerMultiInstance registerOptions-  , not (nativeMultiInstance hpi || recacheMultiInstance hpi)-  = die' verbosity $ "HcPkg.register: the compiler does not support "-       ++ "registering multiple instances of packages."-+  , not (nativeMultiInstance hpi || recacheMultiInstance hpi) =+      dieWithException verbosity RegMultipleInstancePkg   | registerSuppressFilesCheck registerOptions-  , not (suppressFilesCheck hpi)-  = die' verbosity $ "HcPkg.register: the compiler does not support "-                  ++ "suppressing checks on files."--    -- This is a trick. Older versions of GHC do not support the-    -- --enable-multi-instance flag for ghc-pkg register but it turns out that-    -- the same ability is available by using ghc-pkg recache. The recache-    -- command is there to support distro package managers that like to work-    -- by just installing files and running update commands, rather than-    -- special add/remove commands. So the way to register by this method is-    -- to write the package registration file directly into the package db and-    -- then call hc-pkg recache.-    --+  , not (suppressFilesCheck hpi) =+      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-  = do let pkgdb = registrationPackageDB packagedbs-       writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo-       recache hpi verbosity pkgdb--  | otherwise-  = runProgramInvocation verbosity-      (registerInvocation hpi verbosity packagedbs pkgInfo registerOptions)--writeRegistrationFileDirectly :: Verbosity-                              -> HcPkgInfo-                              -> PackageDB-                              -> InstalledPackageInfo-                              -> IO ()-writeRegistrationFileDirectly verbosity hpi (SpecificPackageDB dir) pkgInfo-  | supportsDirDbs hpi-  = do let pkgfile = dir </> prettyShow (installedUnitId pkgInfo) <.> "conf"-       writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo)--  | otherwise-  = die' verbosity $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs"--writeRegistrationFileDirectly verbosity _ _ _ =-    -- We don't know here what the dir for the global or user dbs are,-    -- if that's needed it'll require a bit more plumbing to support.-    die' verbosity $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now"+  , recacheMultiInstance hpi =+      do+        let pkgdb = registrationPackageDB packagedbs+        writeRegistrationFileDirectly verbosity hpi mbWorkDir pkgdb pkgInfo+        recache hpi verbosity mbWorkDir pkgdb+  | otherwise =+      runProgramInvocation+        verbosity+        (registerInvocation hpi 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  -- | Call @hc-pkg@ to unregister a package -- -- > hc-pkg unregister [pkgid] [--user | --global | --package-db]----unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()-unregister hpi verbosity packagedb pkgid =-  runProgramInvocation verbosity-    (unregisterInvocation hpi verbosity packagedb pkgid)-+unregister :: HcPkgInfo -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> IO ()+unregister hpi verbosity mbWorkDir packagedb pkgid =+  runProgramInvocation+    verbosity+    (unregisterInvocation hpi verbosity mbWorkDir packagedb pkgid)  -- | Call @hc-pkg@ to recache the registered packages. -- -- > hc-pkg recache [--user | --global | --package-db]----recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO ()-recache hpi verbosity packagedb =-  runProgramInvocation verbosity-    (recacheInvocation hpi verbosity packagedb)-+recache :: HcPkgInfo -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> IO ()+recache hpi verbosity mbWorkDir packagedb =+  runProgramInvocation+    verbosity+    (recacheInvocation hpi verbosity mbWorkDir packagedb)  -- | Call @hc-pkg@ to expose a package. -- -- > hc-pkg expose [pkgid] [--user | --global | --package-db]----expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()-expose hpi verbosity packagedb pkgid =-  runProgramInvocation verbosity-    (exposeInvocation hpi verbosity packagedb pkgid)+expose+  :: HcPkgInfo+  -> Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> PackageDB+  -> PackageId+  -> IO ()+expose hpi verbosity mbWorkDir packagedb pkgid =+  runProgramInvocation+    verbosity+    (exposeInvocation hpi verbosity mbWorkDir packagedb pkgid)  -- | Call @hc-pkg@ to retrieve a specific package -- -- > hc-pkg describe [pkgid] [--user | --global | --package-db]----describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo]-describe hpi verbosity packagedb pid = do--  output <- getProgramInvocationLBS verbosity-              (describeInvocation hpi verbosity packagedb pid)-    `catchIO` \_ -> return mempty+describe+  :: HcPkgInfo+  -> Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> PackageDBStack+  -> PackageId+  -> IO [InstalledPackageInfo]+describe hpi verbosity mbWorkDir packagedb pid = do+  output <-+    getProgramInvocationLBS+      verbosity+      (describeInvocation hpi verbosity mbWorkDir packagedb pid)+      `catchIO` \_ -> return mempty    case parsePackages output of     Left ok -> return ok-    _       -> die' verbosity $ "failed to parse output of '"-                  ++ programId (hcPkgProgram hpi) ++ " describe " ++ prettyShow pid ++ "'"+    _ -> dieWithException verbosity $ FailedToParseOutputDescribe (programId (hcPkgProgram hpi)) pid  -- | Call @hc-pkg@ to hide a package. -- -- > hc-pkg hide [pkgid] [--user | --global | --package-db]----hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()-hide hpi verbosity packagedb pkgid =-  runProgramInvocation verbosity-    (hideInvocation hpi verbosity packagedb pkgid)-+hide+  :: HcPkgInfo+  -> Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> PackageDB+  -> PackageId+  -> IO ()+hide hpi verbosity mbWorkDir packagedb pkgid =+  runProgramInvocation+    verbosity+    (hideInvocation hpi verbosity mbWorkDir packagedb pkgid)  -- | Call @hc-pkg@ to get all the details of all the packages in the given -- package database.----dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo]-dump hpi verbosity packagedb = do--  output <- getProgramInvocationLBS verbosity-              (dumpInvocation hpi verbosity packagedb)-    `catchIO` \e -> die' verbosity $ programId (hcPkgProgram hpi) ++ " dump failed: "-                       ++ displayException e+dump+  :: HcPkgInfo+  -> Verbosity+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBX (SymbolicPath from (Dir PkgDB))+  -> IO [InstalledPackageInfo]+dump hpi verbosity mbWorkDir packagedb = do+  output <-+    getProgramInvocationLBS+      verbosity+      (dumpInvocation hpi verbosity mbWorkDir packagedb)+      `catchIO` \e ->+        dieWithException verbosity $ DumpFailed (programId (hcPkgProgram hpi)) (displayException e)    case parsePackages output of     Left ok -> return ok-    _       -> die' verbosity $ "failed to parse output of '"-                  ++ programId (hcPkgProgram hpi) ++ " dump'"-+    _ -> dieWithException verbosity $ FailedToParseOutputDump (programId (hcPkgProgram hpi))  parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String] parsePackages lbs0 =-    case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of-        Right ok  -> Left [ setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok ]-        Left msgs -> Right (NE.toList msgs)+  case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of+    Right ok -> Left [setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok]+    Left msgs -> Right (NE.toList msgs)   where     splitPkgs :: LBS.ByteString -> [BS.ByteString]     splitPkgs = checkEmpty . doSplit       where         -- Handle the case of there being no packages at all.         checkEmpty [s] | BS.all isSpace8 s = []-        checkEmpty ss                      = ss+        checkEmpty ss = ss          isSpace8 :: Word8 -> Bool-        isSpace8 9  = True -- '\t'+        isSpace8 9 = True -- '\t'         isSpace8 10 = True -- '\n'         isSpace8 13 = True -- '\r'         isSpace8 32 = True -- ' '-        isSpace8 _  = False+        isSpace8 _ = False          doSplit :: LBS.ByteString -> [BS.ByteString]         doSplit lbs = go (LBS.findIndices (\w -> w == 10 || w == 13) lbs)           where             go :: [Int64] -> [BS.ByteString]-            go []         = [ LBS.toStrict lbs ]-            go (idx:idxs) =-                let (pfx, sfx) = LBS.splitAt idx lbs-                in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of+            go [] = [LBS.toStrict lbs]+            go (idx : idxs) =+              let (pfx, sfx) = LBS.splitAt idx lbs+               in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of                     Just sfx' -> LBS.toStrict pfx : doSplit sfx'-                    Nothing   -> go idxs+                    Nothing -> go idxs              separators :: [LBS.ByteString]             separators = ["\n---\n", "\r\n---\r\n", "\r---\r"]@@ -303,25 +337,25 @@     | otherwise              = Nothing #endif - mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. -- The "pkgroot" is the directory containing the package database. mungePackagePaths pkgroot pkginfo =-    pkginfo {-      importDirs        = mungePaths (importDirs  pkginfo),-      includeDirs       = mungePaths (includeDirs pkginfo),-      libraryDirs       = mungePaths (libraryDirs pkginfo),-      libraryDynDirs    = mungePaths (libraryDynDirs pkginfo),-      frameworkDirs     = mungePaths (frameworkDirs pkginfo),-      haddockInterfaces = mungePaths (haddockInterfaces pkginfo),-      haddockHTMLs      = mungeUrls  (haddockHTMLs pkginfo)+  pkginfo+    { importDirs = mungePaths (importDirs pkginfo)+    , includeDirs = mungePaths (includeDirs pkginfo)+    , libraryDirs = mungePaths (libraryDirs pkginfo)+    , libraryDirsStatic = mungePaths (libraryDirsStatic pkginfo)+    , libraryDynDirs = mungePaths (libraryDynDirs pkginfo)+    , frameworkDirs = mungePaths (frameworkDirs pkginfo)+    , haddockInterfaces = mungePaths (haddockInterfaces pkginfo)+    , haddockHTMLs = mungeUrls (haddockHTMLs pkginfo)     }   where     mungePaths = map mungePath-    mungeUrls  = map mungeUrl+    mungeUrls = map mungeUrl      mungePath p = case stripVarPrefix "${pkgroot}" p of       Just p' -> pkgroot </> p'@@ -331,53 +365,56 @@       Just p' -> toUrlPath pkgroot p'       Nothing -> p -    toUrlPath r p = "file:///"-                 -- URLs always use posix style '/' separators:-                 ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)+    toUrlPath r p =+      "file:///"+        -- URLs always use posix style '/' separators:+        ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)      stripVarPrefix var p =       case splitPath p of-        (root:path') -> case stripPrefix var root of+        (root : path') -> case stripPrefix var root of           Just [sep] | isPathSeparator sep -> Just (joinPath path')-          _                                -> Nothing-        _                                  -> Nothing-+          _ -> Nothing+        _ -> Nothing  -- Older installed package info files did not have the installedUnitId -- field, so if it is missing then we fill it as the source package ID. -- NB: Internal libraries not supported. setUnitId :: InstalledPackageInfo -> InstalledPackageInfo-setUnitId pkginfo@InstalledPackageInfo {-                        installedUnitId = uid,-                        sourcePackageId = pid-                      } | unUnitId uid == ""-                    = pkginfo {-                        installedUnitId = mkLegacyUnitId pid,-                        installedComponentId_ = mkComponentId (prettyShow pid)-                      }+setUnitId+  pkginfo@InstalledPackageInfo+    { installedUnitId = uid+    , sourcePackageId = pid+    }+    | unUnitId uid == "" =+        pkginfo+          { installedUnitId = mkLegacyUnitId pid+          , installedComponentId_ = mkComponentId (prettyShow pid)+          } setUnitId pkginfo = pkginfo - -- | Call @hc-pkg@ to get the source package Id of all the packages in the -- given package database. -- -- This is much less information than with 'dump', but also rather quicker. -- Note in particular that it does not include the 'UnitId', just -- the source 'PackageId' which is not necessarily unique in any package db.----list :: HcPkgInfo -> Verbosity -> PackageDB-     -> IO [PackageId]-list hpi verbosity packagedb = do--  output <- getProgramInvocationOutput verbosity-              (listInvocation hpi verbosity packagedb)-    `catchIO` \_ -> die' verbosity $ programId (hcPkgProgram hpi) ++ " list failed"+list+  :: HcPkgInfo+  -> Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> PackageDB+  -> IO [PackageId]+list hpi verbosity mbWorkDir packagedb = do+  output <-+    getProgramInvocationOutput+      verbosity+      (listInvocation hpi verbosity mbWorkDir packagedb)+      `catchIO` \_ -> dieWithException verbosity $ ListFailed (programId (hcPkgProgram hpi))    case parsePackageIds output of     Just ok -> return ok-    _       -> die' verbosity $ "failed to parse output of '"-                  ++ programId (hcPkgProgram hpi) ++ " list'"-+    _ -> dieWithException verbosity $ FailedToParseOutputList (programId (hcPkgProgram hpi))   where     parsePackageIds = traverse simpleParsec . words @@ -387,130 +424,173 @@  initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation initInvocation hpi verbosity path =-    programInvocation (hcPkgProgram hpi) args+  programInvocation (hcPkgProgram hpi) args   where-    args = ["init", path]+    args =+      ["init", path]         ++ verbosityOpts hpi verbosity  registerInvocation-  :: HcPkgInfo -> Verbosity -> PackageDBStack+  :: HcPkgInfo+  -> Verbosity+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBStackS from   -> InstalledPackageInfo   -> RegisterOptions   -> ProgramInvocation-registerInvocation hpi verbosity packagedbs pkgInfo registerOptions =-    (programInvocation (hcPkgProgram hpi) (args "-")) {-      progInvokeInput         = Just $ IODataText $ showInstalledPackageInfo pkgInfo,-      progInvokeInputEncoding = IOEncodingUTF8+registerInvocation hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions =+  (programInvocationCwd mbWorkDir (hcPkgProgram hpi) (args "-"))+    { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo+    , progInvokeInputEncoding = IOEncodingUTF8     }   where     cmdname       | registerAllowOverwrite registerOptions = "update"-      | registerMultiInstance  registerOptions = "update"-      | otherwise                              = "register"--    args file = [cmdname, file]-             ++ packageDbStackOpts hpi packagedbs-             ++ [ "--enable-multi-instance"-                | registerMultiInstance registerOptions ]-             ++ [ "--force-files"-                | registerSuppressFilesCheck registerOptions ]-             ++ verbosityOpts hpi verbosity--unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId-                     -> ProgramInvocation-unregisterInvocation hpi verbosity packagedb pkgid =-  programInvocation (hcPkgProgram hpi) $-       ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid]-    ++ verbosityOpts hpi verbosity-+      | registerMultiInstance registerOptions = "update"+      | otherwise = "register" -recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB-                  -> ProgramInvocation-recacheInvocation hpi verbosity packagedb =-  programInvocation (hcPkgProgram hpi) $-       ["recache", packageDbOpts hpi packagedb]-    ++ verbosityOpts hpi verbosity+    args file =+      [cmdname, file]+        ++ packageDbStackOpts hpi packagedbs+        ++ [ "--enable-multi-instance"+           | registerMultiInstance registerOptions+           ]+        ++ [ "--force-files"+           | registerSuppressFilesCheck registerOptions+           ]+        ++ verbosityOpts hpi verbosity +unregisterInvocation+  :: HcPkgInfo+  -> Verbosity+  -> 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 -exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId-                 -> ProgramInvocation-exposeInvocation hpi verbosity packagedb pkgid =-  programInvocation (hcPkgProgram hpi) $-       ["expose", packageDbOpts hpi packagedb, prettyShow pkgid]-    ++ verbosityOpts hpi verbosity+recacheInvocation+  :: HcPkgInfo+  -> Verbosity+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBS from+  -> ProgramInvocation+recacheInvocation hpi verbosity mbWorkDir packagedb =+  programInvocationCwd mbWorkDir (hcPkgProgram hpi) $+    ["recache", packageDbOpts hpi packagedb]+      ++ verbosityOpts hpi verbosity -describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId-                   -> ProgramInvocation-describeInvocation hpi verbosity packagedbs pkgid =-  programInvocation (hcPkgProgram hpi) $-       ["describe", prettyShow pkgid]-    ++ packageDbStackOpts hpi packagedbs-    ++ verbosityOpts hpi verbosity+exposeInvocation+  :: HcPkgInfo+  -> Verbosity+  -> 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 -hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId-               -> ProgramInvocation-hideInvocation hpi verbosity packagedb pkgid =-  programInvocation (hcPkgProgram hpi) $-       ["hide", packageDbOpts hpi packagedb, prettyShow pkgid]-    ++ verbosityOpts hpi verbosity+describeInvocation+  :: HcPkgInfo+  -> Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> PackageDBStack+  -> PackageId+  -> ProgramInvocation+describeInvocation hpi verbosity mbWorkDir packagedbs pkgid =+  programInvocationCwd mbWorkDir (hcPkgProgram hpi) $+    ["describe", prettyShow pkgid]+      ++ packageDbStackOpts hpi packagedbs+      ++ verbosityOpts hpi verbosity +hideInvocation+  :: HcPkgInfo+  -> Verbosity+  -> 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 -dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation-dumpInvocation hpi _verbosity packagedb =-    (programInvocation (hcPkgProgram hpi) args) {-      progInvokeOutputEncoding = IOEncodingUTF8+dumpInvocation+  :: HcPkgInfo+  -> Verbosity+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBX (SymbolicPath from (Dir PkgDB))+  -> ProgramInvocation+dumpInvocation hpi _verbosity mbWorkDir packagedb =+  (programInvocationCwd mbWorkDir (hcPkgProgram hpi) args)+    { progInvokeOutputEncoding = IOEncodingUTF8     }   where-    args = ["dump", packageDbOpts hpi packagedb]+    args =+      ["dump", packageDbOpts hpi packagedb]         ++ verbosityOpts hpi silent-           -- We use verbosity level 'silent' because it is important that we-           -- do not contaminate the output with info/debug messages. -listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation-listInvocation hpi _verbosity packagedb =-    (programInvocation (hcPkgProgram hpi) args) {-      progInvokeOutputEncoding = IOEncodingUTF8+-- We use verbosity level 'silent' because it is important that we+-- do not contaminate the output with info/debug messages.++listInvocation+  :: HcPkgInfo+  -> Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> PackageDB+  -> ProgramInvocation+listInvocation hpi _verbosity mbWorkDir packagedb =+  (programInvocationCwd mbWorkDir (hcPkgProgram hpi) args)+    { progInvokeOutputEncoding = IOEncodingUTF8     }   where-    args = ["list", "--simple-output", packageDbOpts hpi packagedb]+    args =+      ["list", "--simple-output", packageDbOpts hpi packagedb]         ++ verbosityOpts hpi silent-           -- We use verbosity level 'silent' because it is important that we-           -- do not contaminate the output with info/debug messages. +-- We use verbosity level 'silent' because it is important that we+-- do not contaminate the output with info/debug messages. -packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String]+packageDbStackOpts :: 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-    where-      specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db-      specific _ = ierror-      ierror :: a-      ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)+  | otherwise = case dbstack of+      (GlobalPackageDB : UserPackageDB : dbs) ->+        "--global"+          : "--user"+          : map specific dbs+      (GlobalPackageDB : dbs) ->+        "--global"+          : ("--no-user-" ++ packageDbFlag hpi)+          : map specific dbs+      _ -> ierror+  where+    specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ 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"+  | flagPackageConf hpi =+      "package-conf"+  | otherwise =+      "package-db" -packageDbOpts :: HcPkgInfo -> PackageDB -> String-packageDbOpts _ GlobalPackageDB        = "--global"-packageDbOpts _ UserPackageDB          = "--user"-packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db+packageDbOpts :: HcPkgInfo -> PackageDBX (SymbolicPath from (Dir PkgDB)) -> String+packageDbOpts _ GlobalPackageDB = "--global"+packageDbOpts _ UserPackageDB = "--user"+packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ interpretSymbolicPathCWD db  verbosityOpts :: HcPkgInfo -> Verbosity -> [String] verbosityOpts hpi v-  | noVerboseFlag hpi-                   = []+  | noVerboseFlag hpi =+      []   | v >= deafening = ["-v2"]-  | v == silent    = ["-v0"]-  | otherwise      = []+  | v == silent = ["-v0"]+  | otherwise = []
src/Distribution/Simple/Program/Hpc.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Program.Hpc -- Copyright   :  Thomas Tuegel 2011@@ -10,22 +12,20 @@ -- Portability :  portable -- -- This module provides an library interface to the @hpc@ program.- module Distribution.Simple.Program.Hpc-    ( markup-    , union-    ) where+  ( markup+  , union+  ) where -import Prelude () import Distribution.Compat.Prelude--import System.Directory (makeRelativeToCurrentDirectory)+import Prelude ()  import Distribution.ModuleName+import Distribution.Pretty import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types-import Distribution.Pretty import Distribution.Simple.Utils+import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version @@ -36,74 +36,107 @@ -- first path in the list. This means that e.g. test suites that import their -- library as a dependency can still work, but those that include the library -- modules directly (in other-modules) don't.-markup :: ConfiguredProgram-       -> Version-       -> Verbosity-       -> FilePath            -- ^ Path to .tix file-       -> [FilePath]          -- ^ Paths to .mix file directories-       -> FilePath            -- ^ Path where html output should be located-       -> [ModuleName]        -- ^ List of modules to include in the report-       -> IO ()-markup hpc hpcVer verbosity tixFile hpcDirs destDir included = do-    hpcDirs' <- if withinRange hpcVer (orLaterVersion version07)-        then return hpcDirs-        else do-            warn verbosity $ "Your version of HPC (" ++ prettyShow hpcVer-                ++ ") does not properly handle multiple search paths. "-                ++ "Coverage report generation may fail unexpectedly. These "-                ++ "issues are addressed in version 0.7 or later (GHC 7.8 or "-                ++ "later)."-                ++ if null droppedDirs-                    then ""-                    else " The following search paths have been abandoned: "-                        ++ show droppedDirs-            return passedDirs+markup+  :: Maybe (SymbolicPath CWD (Dir Pkg))+  -> ConfiguredProgram+  -> Version+  -> Verbosity+  -> SymbolicPath Pkg File+  -- ^ Path to .tix file+  -> [SymbolicPath Pkg (Dir Mix)]+  -- ^ Paths to .mix file directories+  -> SymbolicPath Pkg (Dir Artifacts)+  -- ^ Path where html output should be located+  -> [ModuleName]+  -- ^ List of modules to include in the report+  -> IO ()+markup mbWorkDir hpc hpcVer verbosity tixFile hpcDirs destDir included = do+  hpcDirs' <-+    if withinRange hpcVer (orLaterVersion version07)+      then return hpcDirs+      else do+        warn verbosity $+          "Your version of HPC ("+            ++ prettyShow hpcVer+            ++ ") does not properly handle multiple search paths. "+            ++ "Coverage report generation may fail unexpectedly. These "+            ++ "issues are addressed in version 0.7 or later (GHC 7.8 or "+            ++ "later)."+            ++ if null droppedDirs+              then ""+              else+                " The following search paths have been abandoned: "+                  ++ show droppedDirs+        return passedDirs -    -- Prior to GHC 8.0, hpc assumes all .mix paths are relative.-    hpcDirs'' <- traverse makeRelativeToCurrentDirectory hpcDirs'+  -- Prior to GHC 8.0, hpc assumes all .mix paths are relative.+  hpcDirs'' <- traverse (tryMakeRelative mbWorkDir) hpcDirs' -    runProgramInvocation verbosity-      (markupInvocation hpc tixFile hpcDirs'' destDir included)+  runProgramInvocation+    verbosity+    (markupInvocation mbWorkDir hpc tixFile hpcDirs'' destDir included)   where     version07 = mkVersion [0, 7]     (passedDirs, droppedDirs) = splitAt 1 hpcDirs -markupInvocation :: ConfiguredProgram-                 -> FilePath            -- ^ Path to .tix file-                 -> [FilePath]          -- ^ Paths to .mix file directories-                 -> FilePath            -- ^ Path where html output should be-                                        -- located-                 -> [ModuleName]        -- ^ List of modules to include-                 -> ProgramInvocation-markupInvocation hpc tixFile hpcDirs destDir included =-    let args = [ "markup", tixFile-               , "--destdir=" ++ destDir-               ]-            ++ map ("--hpcdir=" ++) hpcDirs-            ++ ["--include=" ++ prettyShow moduleName-               | moduleName <- included ]-    in programInvocation hpc args+markupInvocation+  :: Maybe (SymbolicPath CWD (Dir Pkg))+  -> ConfiguredProgram+  -> SymbolicPath Pkg File+  -- ^ Path to .tix file+  -> [SymbolicPath Pkg (Dir Mix)]+  -- ^ Paths to .mix file directories+  -> SymbolicPath Pkg (Dir Artifacts)+  -- ^ Path where html output should be+  -- located+  -> [ModuleName]+  -- ^ List of modules to include+  -> ProgramInvocation+markupInvocation mbWorkDir hpc tixFile hpcDirs destDir included =+  let args =+        [ "markup"+        , getSymbolicPath tixFile+        , "--destdir=" ++ getSymbolicPath destDir+        ]+          ++ map (("--hpcdir=" ++) . getSymbolicPath) hpcDirs+          ++ [ "--include=" ++ prettyShow moduleName+             | moduleName <- included+             ]+   in programInvocationCwd mbWorkDir hpc args -union :: ConfiguredProgram-      -> Verbosity-      -> [FilePath]         -- ^ Paths to .tix files-      -> FilePath           -- ^ Path to resultant .tix file-      -> [ModuleName]       -- ^ List of modules to exclude from union-      -> IO ()-union hpc verbosity tixFiles outFile excluded =-    runProgramInvocation verbosity-      (unionInvocation hpc tixFiles outFile excluded)+union+  :: Maybe (SymbolicPath CWD (Dir Pkg))+  -> ConfiguredProgram+  -> Verbosity+  -> [SymbolicPath Pkg File]+  -- ^ Paths to .tix files+  -> SymbolicPath Pkg File+  -- ^ Path to resultant .tix file+  -> [ModuleName]+  -- ^ List of modules to exclude from union+  -> IO ()+union mbWorkDir hpc verbosity tixFiles outFile excluded =+  runProgramInvocation+    verbosity+    (unionInvocation mbWorkDir hpc tixFiles outFile excluded) -unionInvocation :: ConfiguredProgram-                -> [FilePath]       -- ^ Paths to .tix files-                -> FilePath         -- ^ Path to resultant .tix file-                -> [ModuleName]     -- ^ List of modules to exclude from union-                -> ProgramInvocation-unionInvocation hpc tixFiles outFile excluded =-    programInvocation hpc $ concat-        [ ["sum", "--union"]-        , tixFiles-        , ["--output=" ++ outFile]-        , ["--exclude=" ++ prettyShow moduleName-          | moduleName <- excluded ]+unionInvocation+  :: Maybe (SymbolicPath CWD (Dir Pkg))+  -> ConfiguredProgram+  -> [SymbolicPath Pkg File]+  -- ^ Paths to .tix files+  -> SymbolicPath Pkg File+  -- ^ Path to resultant .tix file+  -> [ModuleName]+  -- ^ List of modules to exclude from union+  -> ProgramInvocation+unionInvocation mbWorkDir hpc tixFiles outFile excluded =+  programInvocationCwd mbWorkDir hpc $+    concat+      [ ["sum", "--union"]+      , map getSymbolicPath tixFiles+      , ["--output=" ++ getSymbolicPath outFile]+      , [ "--exclude=" ++ prettyShow moduleName+        | moduleName <- excluded         ]+      ]
src/Distribution/Simple/Program/Internal.hs view
@@ -1,4 +1,5 @@ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Program.Internal --@@ -6,42 +7,47 @@ -- Portability :  portable -- -- Internal utilities used by Distribution.Simple.Program.*.--module Distribution.Simple.Program.Internal (-    stripExtractVersion,+module Distribution.Simple.Program.Internal+  ( stripExtractVersion   ) where -import Prelude () import Distribution.Compat.Prelude-import Distribution.Utils.Generic(safeTail)+import Distribution.Utils.Generic (safeTail)+import Prelude ()  -- | Extract the version number from the output of 'strip --version'. ----- 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+  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                       = filterPar' n xs-        | otherwise                    = x:filterPar' n xs+      filterPar' _ [] = []+      filterPar' n (x : xs)+        | n >= 0 && "(" `isPrefixOf` x = filterPar' (n + 1) ((safeTail x) : xs)+        | n > 0 && any (`isSuffixOf` x) closingParentheses = filterPar' (n - 1) xs+        | n > 0 = filterPar' n xs+        | otherwise = x : filterPar' n xs        filterPar = filterPar' 0--  in case dropWhile (not . numeric) (filterPar . words $ str) of-    (ver:_) ->-      -- take the first two version components-      let isDot         = (== '.')-          (major, rest) = break isDot ver-          minor         = takeWhile isDigit (dropWhile isDot rest)-      in major ++ "." ++ minor-    _ -> ""+   in case dropWhile (not . numeric) (filterPar . words $ str) of+        (ver : _) ->+          -- take the first two version components+          let isDot = (== '.')+              (major, rest) = break isDot ver+              minor = takeWhile isDigit (dropWhile isDot rest)+           in major ++ "." ++ minor+        _ -> ""
src/Distribution/Simple/Program/Ld.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Program.Ld -- Copyright   :  Duncan Coutts 2009@@ -10,83 +12,99 @@ -- Portability :  portable -- -- This module provides an library interface to the @ld@ linker program.--module Distribution.Simple.Program.Ld (-    combineObjectFiles,+module Distribution.Simple.Program.Ld+  ( combineObjectFiles   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import Distribution.Simple.Compiler (arResponseFilesSupported)-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))+import Distribution.Simple.Flag+  ( fromFlagOrDefault+  )+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI) import Distribution.Simple.Program.ResponseFile-         ( withResponseFile )+  ( withResponseFile+  ) import Distribution.Simple.Program.Run-         ( ProgramInvocation, programInvocation, multiStageProgramInvocation-         , runProgramInvocation )+  ( ProgramInvocation+  , multiStageProgramInvocation+  , programInvocationCwd+  , runProgramInvocation+  ) import Distribution.Simple.Program.Types-         ( ConfiguredProgram(..) )-import Distribution.Simple.Setup-         ( fromFlagOrDefault, configUseResponseFiles )+  ( ConfiguredProgram (..)+  )+import Distribution.Simple.Setup.Config+  ( configUseResponseFiles+  ) import Distribution.Simple.Utils-         ( defaultTempFileOptions )+  ( defaultTempFileOptions+  )+import Distribution.Utils.Path import Distribution.Verbosity-         ( Verbosity )+  ( Verbosity+  )  import System.Directory-         ( renameFile )-import System.FilePath-         ( (<.>), takeDirectory )+  ( renameFile+  )  -- | Call @ld -r@ to link a bunch of object files together.----combineObjectFiles :: Verbosity -> LocalBuildInfo -> ConfiguredProgram-                   -> FilePath -> [FilePath] -> IO ()-combineObjectFiles verbosity lbi ld target files = do-+combineObjectFiles+  :: Verbosity+  -> LocalBuildInfo+  -> ConfiguredProgram+  -> SymbolicPath Pkg File+  -> [SymbolicPath Pkg File]+  -> IO ()+combineObjectFiles verbosity lbi ldProg target files = do   -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is,   -- if we have more object files than fit on a single command line then we   -- have a slight problem. What we have to do is link files in batches into   -- a temp object file and then include that one in the next batch. -  let simpleArgs  = ["-r", "-o", target]+  let+    -- See Note [Symbolic paths] in Distribution.Utils.Path+    u :: SymbolicPath Pkg to -> FilePath+    u = interpretSymbolicPathCWD+    i = interpretSymbolicPath mbWorkDir+    mbWorkDir = mbWorkDirLBI lbi -      initialArgs = ["-r", "-o", target]-      middleArgs  = ["-r", "-o", target, tmpfile]-      finalArgs   = middleArgs+    simpleArgs = ["-r", "-o", u target]+    initialArgs = ["-r", "-o", u target]+    middleArgs = ["-r", "-o", u target, u tmpfile]+    finalArgs = middleArgs -      simple      = programInvocation ld simpleArgs-      initial     = programInvocation ld initialArgs-      middle      = programInvocation ld middleArgs-      final       = programInvocation ld finalArgs+    ld = programInvocationCwd (mbWorkDirLBI lbi) ldProg+    simple = ld simpleArgs+    initial = ld initialArgs+    middle = ld middleArgs+    final = ld finalArgs -      targetDir   = takeDirectory target+    invokeWithResponseFile :: FilePath -> ProgramInvocation+    invokeWithResponseFile atFile =+      ld $ simpleArgs ++ ['@' : atFile] -      invokeWithResponesFile :: FilePath -> ProgramInvocation-      invokeWithResponesFile atFile =-        programInvocation ld $ simpleArgs ++ ['@' : atFile]+    oldVersionManualOverride =+      fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi+    -- Whether ghc's ar supports response files is a good proxy for+    -- whether ghc's ld supports them as well.+    responseArgumentsNotSupported =+      not (arResponseFilesSupported (compiler lbi)) -      oldVersionManualOverride =-        fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi-      -- Whether ghc's ar supports response files is a good proxy for-      -- whether ghc's ld supports them as well.-      responseArgumentsNotSupported   =-        not (arResponseFilesSupported (compiler lbi))+    run :: [ProgramInvocation] -> IO ()+    run [] = return ()+    run [inv] = runProgramInvocation verbosity inv+    run (inv : invs) = do+      runProgramInvocation verbosity inv+      renameFile (i target) (i tmpfile)+      run invs    if oldVersionManualOverride || responseArgumentsNotSupported-    then-      run $ multiStageProgramInvocation simple (initial, middle, final) files-    else-      withResponseFile verbosity defaultTempFileOptions targetDir "ld.rsp" Nothing files $-        \path -> runProgramInvocation verbosity $ invokeWithResponesFile path-+    then run $ multiStageProgramInvocation simple (initial, middle, final) (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--    run :: [ProgramInvocation] -> IO ()-    run []         = return ()-    run [inv]      = runProgramInvocation verbosity inv-    run (inv:invs) = do runProgramInvocation verbosity inv-                        renameFile target tmpfile-                        run invs+    tmpfile = target <.> "tmp" -- perhaps should use a proper temp file
src/Distribution/Simple/Program/ResponseFile.hs view
@@ -1,6 +1,11 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes       #-}+{-# LANGUAGE RankNTypes #-}+ ----------------------------------------------------------------------------++----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Program.ResponseFile -- Copyright   :  (c) Sergey Vinokurov 2017@@ -8,30 +13,35 @@ -- -- Maintainer  :  cabal-devel@haskell.org -- Created     :  23 July 2017------------------------------------------------------------------------------ module Distribution.Simple.Program.ResponseFile (withResponseFile) where +import System.IO (TextEncoding, hClose, hPutStr, hSetEncoding) import Prelude ()-import System.IO (TextEncoding, hSetEncoding, hPutStr, hClose)  import Distribution.Compat.Prelude-import Distribution.Simple.Utils (TempFileOptions, withTempFileEx, debug)+import Distribution.Simple.Utils (TempFileOptions, debug, withTempFileEx)+import Distribution.Utils.Path import Distribution.Verbosity  withResponseFile   :: Verbosity   -> TempFileOptions-  -> FilePath           -- ^ Working directory to create response file in.-  -> FilePath           -- ^ Template for response file name.-  -> Maybe TextEncoding -- ^ Encoding to use for response file contents.-  -> [String]           -- ^ Arguments to put into response file.+  -> String+  -- ^ Template for response file name.+  -> Maybe TextEncoding+  -- ^ Encoding to use for response file contents.+  -> [String]+  -- ^ Arguments to put into response file.   -> (FilePath -> IO a)   -> IO a-withResponseFile verbosity tmpFileOpts workDir fileNameTemplate encoding arguments f =-  withTempFileEx tmpFileOpts workDir fileNameTemplate $ \responseFileName hf -> do+withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f =+  withTempFileEx tmpFileOpts fileNameTemplate $ \responsePath hf -> do+    let responseFileName = getSymbolicPath responsePath     traverse_ (hSetEncoding hf) encoding-    let responseContents = unlines $ map escapeResponseFileArg arguments+    let responseContents =+          unlines $+            map escapeResponseFileArg $+              arguments     hPutStr hf responseContents     hClose hf     debug verbosity $ responseFileName ++ " contents: <<<"@@ -51,10 +61,9 @@     escape :: String -> Char -> String     escape cs c =       case c of-        '\\'          -> c:'\\':cs-        '\''          -> c:'\\':cs-        '"'           -> c:'\\':cs-        _ | isSpace c -> c:'\\':cs-          | otherwise -> c:cs--+        '\\' -> c : '\\' : cs+        '\'' -> c : '\\' : cs+        '"' -> c : '\\' : cs+        _+          | isSpace c -> c : '\\' : cs+          | otherwise -> c : cs
src/Distribution/Simple/Program/Run.hs view
@@ -1,8 +1,11 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs            #-}-{-# LANGUAGE RankNTypes       #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Program.Run -- Copyright   :  Duncan Coutts 2009@@ -12,36 +15,36 @@ -- -- This module provides a data type for program invocations and functions to -- run them.--module Distribution.Simple.Program.Run (-    ProgramInvocation(..),-    IOEncoding(..),-    emptyProgramInvocation,-    simpleProgramInvocation,-    programInvocation,-    multiStageProgramInvocation,--    runProgramInvocation,-    getProgramInvocationOutput,-    getProgramInvocationLBS,-    getProgramInvocationOutputAndErrors,--    getEffectiveEnvironment,+module Distribution.Simple.Program.Run+  ( ProgramInvocation (..)+  , IOEncoding (..)+  , emptyProgramInvocation+  , simpleProgramInvocation+  , programInvocation+  , programInvocationCwd+  , multiStageProgramInvocation+  , runProgramInvocation+  , getProgramInvocationOutput+  , getProgramInvocationLBS+  , getProgramInvocationOutputAndErrors+  , getProgramInvocationLBSAndErrors+  , getEffectiveEnvironment+  , getFullEnvironment   ) where  import Distribution.Compat.Prelude import Prelude ()  import Distribution.Compat.Environment+import Distribution.Simple.Errors import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.Utils.Generic+import Distribution.Utils.Path import Distribution.Verbosity -import System.FilePath (searchPathSeparator)- import qualified Data.ByteString.Lazy as LBS-import qualified Data.Map             as Map+import qualified Data.Map as Map  -- | Represents a specific invocation of a specific program. --@@ -49,180 +52,220 @@ -- and actually doing it. This provides the opportunity to the caller to -- adjust how the program will be called. These invocations can either be run -- directly or turned into shell or batch scripts.----data ProgramInvocation = ProgramInvocation {-       progInvokePath  :: FilePath,-       progInvokeArgs  :: [String],-       progInvokeEnv   :: [(String, Maybe String)],-       -- Extra paths to add to PATH-       progInvokePathEnv :: [FilePath],-       progInvokeCwd   :: Maybe FilePath,-       progInvokeInput :: Maybe IOData,-       progInvokeInputEncoding  :: IOEncoding, -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'.-       progInvokeOutputEncoding :: IOEncoding-     }+data ProgramInvocation = ProgramInvocation+  { progInvokePath :: FilePath+  , progInvokeArgs :: [String]+  , progInvokeEnv :: [(String, Maybe String)]+  , progInvokeCwd :: Maybe FilePath+  , progInvokeInput :: Maybe IOData+  , progInvokeInputEncoding :: IOEncoding+  -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'.+  , progInvokeOutputEncoding :: IOEncoding+  , progInvokeWhen :: IO Bool+  } -data IOEncoding = IOEncodingText   -- locale mode text-                | IOEncodingUTF8   -- always utf8+data IOEncoding+  = IOEncodingText -- locale mode text+  | IOEncodingUTF8 -- always utf8  encodeToIOData :: IOEncoding -> IOData -> IOData-encodeToIOData _              iod@(IODataBinary _) = iod-encodeToIOData IOEncodingText iod@(IODataText _)   = iod-encodeToIOData IOEncodingUTF8 (IODataText str)     = IODataBinary (toUTF8LBS str)+encodeToIOData _ iod@(IODataBinary _) = iod+encodeToIOData IOEncodingText iod@(IODataText _) = iod+encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str)  emptyProgramInvocation :: ProgramInvocation emptyProgramInvocation =-  ProgramInvocation {-    progInvokePath  = "",-    progInvokeArgs  = [],-    progInvokeEnv   = [],-    progInvokePathEnv = [],-    progInvokeCwd   = Nothing,-    progInvokeInput = Nothing,-    progInvokeInputEncoding  = IOEncodingText,-    progInvokeOutputEncoding = IOEncodingText-  }+  ProgramInvocation+    { progInvokePath = ""+    , progInvokeArgs = []+    , progInvokeEnv = []+    , progInvokeCwd = Nothing+    , progInvokeInput = Nothing+    , progInvokeInputEncoding = IOEncodingText+    , progInvokeOutputEncoding = IOEncodingText+    , progInvokeWhen = pure True+    } -simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation+simpleProgramInvocation+  :: FilePath+  -> [String]+  -> ProgramInvocation simpleProgramInvocation path args =-  emptyProgramInvocation {-    progInvokePath  = path,-    progInvokeArgs  = args-  }+  emptyProgramInvocation+    { progInvokePath = path+    , progInvokeArgs = args+    } -programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation+programInvocation+  :: ConfiguredProgram+  -> [String]+  -> ProgramInvocation programInvocation prog args =-  emptyProgramInvocation {-    progInvokePath = programPath prog,-    progInvokeArgs = programDefaultArgs prog-                  ++ args-                  ++ programOverrideArgs prog,-    progInvokeEnv  = programOverrideEnv prog-  }+  emptyProgramInvocation+    { progInvokePath = programPath prog+    , progInvokeArgs =+        programDefaultArgs prog+          ++ args+          ++ programOverrideArgs prog+    , progInvokeEnv = programOverrideEnv prog+    } +programInvocationCwd+  :: forall to+   . Maybe (SymbolicPath CWD (Dir to))+  -> ConfiguredProgram+  -> [String]+  -> ProgramInvocation+programInvocationCwd mbWorkDir prog args =+  (programInvocation prog args)+    { progInvokeCwd = fmap getSymbolicPath mbWorkDir+    }  runProgramInvocation :: Verbosity -> ProgramInvocation -> IO ()-runProgramInvocation verbosity-  ProgramInvocation {-    progInvokePath  = path,-    progInvokeArgs  = args,-    progInvokeEnv   = [],-    progInvokePathEnv = [],-    progInvokeCwd   = Nothing,-    progInvokeInput = Nothing-  } =-  rawSystemExit verbosity path args--runProgramInvocation verbosity-  ProgramInvocation {-    progInvokePath  = path,-    progInvokeArgs  = args,-    progInvokeEnv   = envOverrides,-    progInvokePathEnv = extraPath,-    progInvokeCwd   = mcwd,-    progInvokeInput = Nothing-  } = do-    pathOverride <- getExtraPathEnv envOverrides extraPath-    menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)-    exitCode <- rawSystemIOWithEnv verbosity-                                   path args-                                   mcwd menv-                                   Nothing Nothing Nothing-    when (exitCode /= ExitSuccess) $-      exitWith exitCode--runProgramInvocation verbosity-  ProgramInvocation {-    progInvokePath  = path,-    progInvokeArgs  = args,-    progInvokeEnv   = envOverrides,-    progInvokePathEnv = extraPath,-    progInvokeCwd   = mcwd,-    progInvokeInput = Just inputStr,-    progInvokeInputEncoding = encoding-  } = do-    pathOverride <- getExtraPathEnv envOverrides extraPath-    menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)-    (_, errors, exitCode) <- rawSystemStdInOut verbosity-                                    path args-                                    mcwd menv-                                    (Just input) IODataModeBinary+runProgramInvocation+  verbosity+  ProgramInvocation+    { progInvokePath = path+    , progInvokeArgs = args+    , progInvokeEnv = []+    , progInvokeCwd = Nothing+    , progInvokeInput = Nothing+    } =+    rawSystemExit verbosity Nothing path args+runProgramInvocation+  verbosity+  ProgramInvocation+    { progInvokePath = path+    , progInvokeArgs = args+    , progInvokeEnv = envOverrides+    , progInvokeCwd = mcwd+    , progInvokeInput = Nothing+    } = do+    menv <- getEffectiveEnvironment envOverrides+    maybeExit $+      rawSystemIOWithEnv+        verbosity+        path+        args+        mcwd+        menv+        Nothing+        Nothing+        Nothing+runProgramInvocation+  verbosity+  ProgramInvocation+    { progInvokePath = path+    , progInvokeArgs = args+    , progInvokeEnv = envOverrides+    , progInvokeCwd = mcwd+    , progInvokeInput = Just inputStr+    , progInvokeInputEncoding = encoding+    } = do+    menv <- getEffectiveEnvironment envOverrides+    (_, errors, exitCode) <-+      rawSystemStdInOut+        verbosity+        path+        args+        mcwd+        menv+        (Just input)+        IODataModeBinary     when (exitCode /= ExitSuccess) $-      die' verbosity $ "'" ++ path ++ "' exited with an error:\n" ++ errors-  where-    input = encodeToIOData encoding inputStr+      dieWithException verbosity $+        RunProgramInvocationException path errors+    where+      input = encodeToIOData encoding inputStr  getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String getProgramInvocationOutput verbosity inv = do-    (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv-    when (exitCode /= ExitSuccess) $-      die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors-    return output+  (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv+  when (exitCode /= ExitSuccess) $+    die' verbosity $+      "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors+  return output  getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO LBS.ByteString getProgramInvocationLBS verbosity inv = do-    (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary-    when (exitCode /= ExitSuccess) $-      die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors-    return output+  (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary+  when (exitCode /= ExitSuccess) $+    dieWithException verbosity $+      GetProgramInvocationLBSException (progInvokePath inv) errors+  return output -getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation-                                    -> IO (String, String, ExitCode)+getProgramInvocationOutputAndErrors+  :: Verbosity+  -> ProgramInvocation+  -> IO (String, String, ExitCode) getProgramInvocationOutputAndErrors verbosity inv = case progInvokeOutputEncoding inv of-    IOEncodingText -> do-        (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText-        return (output, errors, exitCode)-    IOEncodingUTF8 -> do-        (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary-        return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode)+  IOEncodingText -> do+    (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText+    return (output, errors, exitCode)+  IOEncodingUTF8 -> do+    (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary+    return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode) +getProgramInvocationLBSAndErrors+  :: Verbosity+  -> ProgramInvocation+  -> IO (LBS.ByteString, String, ExitCode)+getProgramInvocationLBSAndErrors verbosity inv =+  getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary+ getProgramInvocationIODataAndErrors-    :: KnownIODataMode mode => Verbosity -> ProgramInvocation -> IODataMode mode-    -> IO (mode, String, ExitCode)+  :: KnownIODataMode mode+  => Verbosity+  -> ProgramInvocation+  -> IODataMode mode+  -> IO (mode, String, ExitCode) getProgramInvocationIODataAndErrors   verbosity   ProgramInvocation-    { progInvokePath          = path-    , progInvokeArgs          = args-    , progInvokeEnv           = envOverrides-    , progInvokePathEnv       = extraPath-    , progInvokeCwd           = mcwd-    , progInvokeInput         = minputStr+    { progInvokePath = path+    , progInvokeArgs = args+    , progInvokeEnv = envOverrides+    , progInvokeCwd = mcwd+    , progInvokeInput = minputStr     , progInvokeInputEncoding = encoding     }   mode = do-    pathOverride <- getExtraPathEnv envOverrides extraPath-    menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)+    menv <- getEffectiveEnvironment envOverrides     rawSystemStdInOut verbosity path args mcwd menv input mode-  where-    input = encodeToIOData encoding <$> minputStr--getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> IO [(String, Maybe String)]-getExtraPathEnv _ [] = return []-getExtraPathEnv env extras = do-    mb_path <- case lookup "PATH" env of-                Just x  -> return x-                Nothing -> lookupEnv "PATH"-    let extra = intercalate [searchPathSeparator] extras-        path' = case mb_path of-                    Nothing   -> extra-                    Just path -> extra ++ searchPathSeparator : path-    return [("PATH", Just path')]+    where+      input = encodeToIOData encoding <$> minputStr  -- | Return the current environment extended with the given overrides. -- If an entry is specified twice in @overrides@, the second entry takes -- precedence. ---getEffectiveEnvironment :: [(String, Maybe String)]-                        -> IO (Maybe [(String, String)])-getEffectiveEnvironment []        = return Nothing+-- getEffectiveEnvironment returns 'Nothing' when there are no overrides.+-- It returns an argument that is suitable to pass directly to 'CreateProcess' to+-- override the environment.+-- If you need the full environment to manipulate further, even when there are no overrides,+-- then call 'getFullEnvironment'.+getEffectiveEnvironment+  :: [(String, Maybe String)]+  -> IO (Maybe [(String, String)])+getEffectiveEnvironment [] = return Nothing getEffectiveEnvironment overrides =-    fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment+  fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment   where     apply os env = foldl' (flip update) env os-    update (var, Nothing)  = Map.delete var+    update (var, Nothing) = Map.delete var     update (var, Just val) = Map.insert var val +-- | Like 'getEffectiveEnvironment', but when no overrides are specified,+-- returns the full environment instead of 'Nothing'.+getFullEnvironment+  :: [(String, Maybe String)]+  -> IO [(String, String)]+getFullEnvironment overrides = do+  menv <- getEffectiveEnvironment overrides+  case menv of+    Just env -> return env+    Nothing -> getEnvironment+ -- | Like the unix xargs program. Useful for when we've got very long command -- lines that might overflow an OS limit on command line length and so you -- need to invoke a command multiple times to get all the args in.@@ -242,53 +285,51 @@ -- > $ middle  args_2 -- >   ... -- > $ final   args_n--- multiStageProgramInvocation   :: ProgramInvocation   -> (ProgramInvocation, ProgramInvocation, ProgramInvocation)   -> [String]   -> [ProgramInvocation] multiStageProgramInvocation simple (initial, middle, final) args =--  let argSize inv  = length (progInvokePath inv)-                   + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv)+  let argSize inv =+        length (progInvokePath inv)+          + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv)       fixedArgSize = maximum (map argSize [simple, initial, middle, final])-      chunkSize    = maxCommandLineSize - fixedArgSize-+      chunkSize = maxCommandLineSize - fixedArgSize    in case splitChunks chunkSize args of-        []  -> [ simple ]--        [c] -> [ simple  `appendArgs` c ]--        (c:c2:cs) | (xs, x) <- unsnocNE (c2:|cs) ->-             [ initial `appendArgs` c ]-          ++ [ middle  `appendArgs` c'| c' <- xs ]-          ++ [ final   `appendArgs` x ]-+        [] -> [simple]+        [c] -> [simple `appendArgs` c]+        (c : c2 : cs)+          | (xs, x) <- unsnocNE (c2 :| cs) ->+              [initial `appendArgs` c]+                ++ [middle `appendArgs` c' | c' <- xs]+                ++ [final `appendArgs` x]   where     appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation-    inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as }+    inv `appendArgs` as = inv{progInvokeArgs = progInvokeArgs inv ++ as}      splitChunks :: Int -> [[a]] -> [[[a]]]     splitChunks len = unfoldr $ \s ->-      if null s then Nothing-                else Just (chunk len s)+      if null s+        then Nothing+        else Just (chunk len s)      chunk :: Int -> [[a]] -> ([[a]], [[a]])-    chunk len (s:_) | length s >= len = error toolong-    chunk len ss    = chunk' [] len ss+    chunk len (s : _) | length s >= len = error toolong+    chunk len ss = chunk' [] len ss      chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]])-    chunk' acc len (s:ss)-      | len' < len = chunk' (s:acc) (len-len'-1) ss-      where len' = length s-    chunk' acc _   ss     = (reverse acc, ss)--    toolong = "multiStageProgramInvocation: a single program arg is larger "-           ++ "than the maximum command line length!"+    chunk' acc len (s : ss)+      | len' < len = chunk' (s : acc) (len - len' - 1) ss+      where+        len' = length s+    chunk' acc _ ss = (reverse acc, ss) +    toolong =+      "multiStageProgramInvocation: a single program arg is larger "+        ++ "than the maximum command line length!" ---FIXME: discover this at configure time or runtime on unix+-- FIXME: discover this at configure time or runtime on unix -- The value is 32k on Windows and posix specifies a minimum of 4k -- but all sensible unixes use more than 4k. -- we could use getSysVar ArgumentLimit but that's in the unix lib
src/Distribution/Simple/Program/Script.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE GADTs #-}+ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Program.Script -- Copyright   :  Duncan Coutts 2009@@ -9,16 +11,14 @@ -- -- This module provides an library interface to the @hc-pkg@ program. -- Currently only GHC and LHC have hc-pkg programs.--module Distribution.Simple.Program.Script (--    invocationAsSystemScript,-    invocationAsShellScript,-    invocationAsBatchFile,+module Distribution.Simple.Program.Script+  ( invocationAsSystemScript+  , invocationAsShellScript+  , invocationAsBatchFile   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import Distribution.Simple.Program.Run import Distribution.Simple.Utils@@ -26,89 +26,89 @@  -- | Generate a system script, either POSIX shell script or Windows batch file -- as appropriate for the given system.--- invocationAsSystemScript :: OS -> ProgramInvocation -> String invocationAsSystemScript Windows = invocationAsBatchFile-invocationAsSystemScript _       = invocationAsShellScript-+invocationAsSystemScript _ = invocationAsShellScript  -- | Generate a POSIX shell script that invokes a program.--- invocationAsShellScript :: ProgramInvocation -> String invocationAsShellScript-  ProgramInvocation {-    progInvokePath  = path,-    progInvokeArgs  = args,-    progInvokeEnv   = envExtra,-    progInvokeCwd   = mcwd,-    progInvokeInput = minput-  } = unlines $-          [ "#!/bin/sh" ]-       ++ concatMap setEnv envExtra-       ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ]-       ++ [ (case minput of-              Nothing     -> ""-              Just input -> "echo " ++ quote (iodataToText input) ++ " | ")-         ++ unwords (map quote $ path : args) ++ " \"$@\""]--  where-    setEnv (var, Nothing)  = ["unset " ++ var, "export " ++ var]-    setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val]+  ProgramInvocation+    { progInvokePath = path+    , progInvokeArgs = args+    , progInvokeEnv = envExtra+    , progInvokeCwd = mcwd+    , progInvokeInput = minput+    } =+    unlines $+      ["#!/bin/sh"]+        ++ concatMap setEnv envExtra+        ++ ["cd " ++ quote cwd | cwd <- maybeToList mcwd]+        ++ [ ( case minput of+                Nothing -> ""+                Just input -> "printf '%s' " ++ quote (iodataToText input) ++ " | "+             )+              ++ unwords (map quote $ path : args)+              ++ " \"$@\""+           ]+    where+      setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var]+      setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val] -    quote :: String -> String-    quote s = "'" ++ escape s ++ "'"+      quote :: String -> String+      quote s = "'" ++ escape s ++ "'" -    escape []        = []-    escape ('\'':cs) = "'\\''" ++ escape cs-    escape (c   :cs) = c        : escape cs+      escape [] = []+      escape ('\'' : cs) = "'\\''" ++ escape cs+      escape (c : cs) = c : escape cs  iodataToText :: IOData -> String-iodataToText (IODataText str)   = str+iodataToText (IODataText str) = str iodataToText (IODataBinary lbs) = fromUTF8LBS lbs - -- | Generate a Windows batch file that invokes a program.--- invocationAsBatchFile :: ProgramInvocation -> String invocationAsBatchFile-  ProgramInvocation {-    progInvokePath  = path,-    progInvokeArgs  = args,-    progInvokeEnv   = envExtra,-    progInvokeCwd   = mcwd,-    progInvokeInput = minput-  } = unlines $-          [ "@echo off" ]-       ++ map setEnv envExtra-       ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ]-       ++ case minput of-            Nothing    ->-                [ path ++ concatMap (' ':) args ]--            Just input ->-                [ "(" ]-             ++ [ "echo " ++ escape line | line <- lines $ iodataToText input ]-             ++ [ ") | "-               ++ "\"" ++ path ++ "\""-               ++ concatMap (\arg -> ' ':quote arg) args ]--  where-    setEnv (var, Nothing)  = "set " ++ var ++ "="-    setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val+  ProgramInvocation+    { progInvokePath = path+    , progInvokeArgs = args+    , progInvokeEnv = envExtra+    , progInvokeCwd = mcwd+    , progInvokeInput = minput+    } =+    unlines $+      ["@echo off"]+        ++ map setEnv envExtra+        ++ ["cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd]+        ++ case minput of+          Nothing ->+            [path ++ concatMap (' ' :) args]+          Just input ->+            ["("]+              ++ ["echo " ++ escape line | line <- lines $ iodataToText input]+              ++ [ ") | "+                    ++ "\""+                    ++ path+                    ++ "\""+                    ++ concatMap (\arg -> ' ' : quote arg) args+                 ]+    where+      setEnv (var, Nothing) = "set " ++ var ++ "="+      setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val -    quote :: String -> String-    quote s = "\"" ++ escapeQ s ++ "\""+      quote :: String -> String+      quote s = "\"" ++ escapeQ s ++ "\"" -    escapeQ []       = []-    escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs-    escapeQ (c  :cs) = c         : escapeQ cs+      escapeQ [] = []+      escapeQ ('"' : cs) = "\"\"\"" ++ escapeQ cs+      escapeQ (c : cs) = c : escapeQ cs -    escape []        = []-    escape ('|':cs) = "^|" ++ escape cs-    escape ('<':cs) = "^<" ++ escape cs-    escape ('>':cs) = "^>" ++ escape cs-    escape ('&':cs) = "^&" ++ escape cs-    escape ('(':cs) = "^(" ++ escape cs-    escape (')':cs) = "^)" ++ escape cs-    escape ('^':cs) = "^^" ++ escape cs-    escape (c  :cs) = c     : escape cs+      escape [] = []+      escape ('|' : cs) = "^|" ++ escape cs+      escape ('<' : cs) = "^<" ++ escape cs+      escape ('>' : cs) = "^>" ++ escape cs+      escape ('&' : cs) = "^&" ++ escape cs+      escape ('(' : cs) = "^(" ++ escape cs+      escape (')' : cs) = "^)" ++ escape cs+      escape ('^' : cs) = "^^" ++ escape cs+      escape (c : cs) = c : escape cs
src/Distribution/Simple/Program/Strip.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Program.Strip --@@ -9,12 +10,11 @@ -- Portability :  portable -- -- This module provides an library interface to the @strip@ program.- module Distribution.Simple.Program.Strip (stripLib, stripExe)-       where+where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import Distribution.Simple.Program import Distribution.Simple.Utils@@ -22,54 +22,66 @@ import Distribution.Verbosity import Distribution.Version -import System.FilePath             (takeBaseName)+import System.FilePath (takeBaseName)  runStrip :: Verbosity -> ProgramDb -> FilePath -> [String] -> IO () runStrip verbosity progDb path args =   case lookupProgram stripProgram progDb of     Just strip -> runProgram verbosity strip (args ++ [path])-    Nothing    -> unless (buildOS == Windows) $-                  -- Don't bother warning on windows, we don't expect them to-                  -- have the strip program anyway.-                  warn verbosity $ "Unable to strip executable or library '"-                                   ++ (takeBaseName path)-                                   ++ "' (missing the 'strip' program)"+    Nothing ->+      unless (buildOS == Windows) $+        -- Don't bother warning on windows, we don't expect them to+        -- have the strip program anyway.+        warn verbosity $+          "Unable to strip executable or library '"+            ++ (takeBaseName path)+            ++ "' (missing the 'strip' program)"  stripExe :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () stripExe verbosity (Platform _arch os) progdb path =   runStrip verbosity progdb path args   where     args = case os of-       OSX -> ["-x"] -- By default, stripping the ghc binary on at least-                     -- some OS X installations causes:-                     --     HSbase-3.0.o: unknown symbol `_environ'"-                     -- The -x flag fixes that.-       _   -> []+      OSX -> ["-x"] -- By default, stripping the ghc binary on at least+      -- some OS X installations causes:+      --     HSbase-3.0.o: unknown symbol `_environ'"+      -- The -x flag fixes that.+      _ -> []  stripLib :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () stripLib verbosity (Platform arch os) progdb path = do   case os of-    OSX -> -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or-           -- Solaris. See #1630.-           return ()+    OSX ->+      -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or+      -- Solaris. See #1630.+      return ()     IOS -> return ()     AIX -> return ()     Solaris -> return ()-    Windows -> -- Stripping triggers a bug in 'strip.exe' for-               -- libraries with lots identically named modules. See-               -- #1784.-               return()-    Linux | arch == I386 ->-      -- Versions of 'strip' on 32-bit Linux older than 2.18 are-      -- broken. See #2339.-      let okVersion = orLaterVersion (mkVersion [2,18])-      in case programVersion =<< lookupProgram stripProgram progdb of-          Just v | withinRange v okVersion ->-            runStrip verbosity progdb path args-          _ -> warn verbosity $ "Unable to strip library '"-                                ++ (takeBaseName path)-                                ++ "' (version of 'strip' too old; "-                                ++ "requires >= 2.18 on 32-bit Linux)"-    _   -> runStrip verbosity progdb path args+    OpenBSD ->+      -- '--strip-unneeded' sometimes strips too much on OpenBSD.+      -- -- See https://cvsweb.openbsd.org/cgi-bin/cvsweb/~checkout~/ports/lang/ghc/patches/patch-libraries_Cabal_Cabal_Distribution_Simple_Program_Strip_hs+      return ()+    Windows ->+      -- Stripping triggers a bug in 'strip.exe' for+      -- libraries with lots identically named modules. See+      -- #1784.+      return ()+    Linux+      | arch == I386 ->+          -- Versions of 'strip' on 32-bit Linux older than 2.18 are+          -- broken. See #2339.+          let okVersion = orLaterVersion (mkVersion [2, 18])+           in case programVersion =<< lookupProgram stripProgram progdb of+                Just v+                  | withinRange v okVersion ->+                      runStrip verbosity progdb path args+                _ ->+                  warn verbosity $+                    "Unable to strip library '"+                      ++ (takeBaseName path)+                      ++ "' (version of 'strip' too old; "+                      ++ "requires >= 2.18 on 32-bit Linux)"+    _ -> runStrip verbosity progdb path args   where     args = ["--strip-unneeded"]
src/Distribution/Simple/Program/Types.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DeriveDataTypeable #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Program.Types -- Copyright   :  Isaac Jones 2006, Duncan Coutts 2007-2009@@ -19,30 +18,27 @@ -- args). Configuring a program involves finding its location and if necessary -- finding its version. There's reasonable default behavior for trying to find -- \"foo\" in PATH, being able to override its location, etc.----module Distribution.Simple.Program.Types (-    -- * Program and functions for constructing them-    Program(..),-    ProgramSearchPath,-    ProgramSearchPathEntry(..),-    simpleProgram,+module Distribution.Simple.Program.Types+  ( -- * Program and functions for constructing them+    Program (..)+  , ProgramSearchPath+  , ProgramSearchPathEntry (..)      -- * Configured program and related functions-    ConfiguredProgram(..),-    programPath,-    suppressOverrideArgs,-    ProgArg,-    ProgramLocation(..),-    simpleConfiguredProgram,+  , ConfiguredProgram (..)+  , programPath+  , suppressOverrideArgs+  , ProgArg+  , ProgramLocation (..)+  , simpleConfiguredProgram   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import Distribution.PackageDescription-import Distribution.Simple.Program.Find-import Distribution.Version import Distribution.Verbosity+import Distribution.Version  import qualified Data.Map as Map @@ -50,88 +46,107 @@ -- -- Note: rather than constructing this directly, start with 'simpleProgram' and -- override any extra fields.----data Program = Program {-       -- | The simple name of the program, eg. ghc-       programName :: String,--       -- | A function to search for the program if its location was not-       -- specified by the user. Usually this will just be a call to-       -- 'findProgramOnSearchPath'.-       ---       -- It is supplied with the prevailing search path which will typically-       -- just be used as-is, but can be extended or ignored as needed.-       ---       -- For the purpose of change monitoring, in addition to the location-       -- where the program was found, it returns all the other places that-       -- were tried.-       ---       programFindLocation :: Verbosity -> ProgramSearchPath-                              -> IO (Maybe (FilePath, [FilePath])),--       -- | Try to find the version of the program. For many programs this is-       -- not possible or is not necessary so it's OK to return Nothing.-       programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version),+data Program = Program+  { programName :: String+  -- ^ The simple name of the program, eg. ghc+  , programFindLocation+      :: Verbosity+      -> ProgramSearchPath+      -> IO (Maybe (FilePath, [FilePath]))+  -- ^ A function to search for the program if its location was not+  -- specified by the user. Usually this will just be a call to+  -- 'findProgramOnSearchPath'.+  --+  -- It is supplied with the prevailing search path which will typically+  -- just be used as-is, but can be extended or ignored as needed.+  --+  -- For the purpose of change monitoring, in addition to the location+  -- where the program was found, it returns all the other places that+  -- were tried.+  , programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version)+  -- ^ Try to find the version of the program. For many programs this is+  -- not possible or is not necessary so it's OK to return Nothing.+  , programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram+  -- ^ A function to do any additional configuration after we have+  -- located the program (and perhaps identified its version). For example+  -- it could add args, or environment vars.+  , programNormaliseArgs :: Maybe Version -> PackageDescription -> [String] -> [String]+  -- ^ A function that filters any arguments that don't impact the output+  -- from a commandline. Used to limit the volatility of dependency hashes+  -- when using new-build.+  } -       -- | A function to do any additional configuration after we have-       -- located the program (and perhaps identified its version). For example-       -- it could add args, or environment vars.-       programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram,-       -- | A function that filters any arguments that don't impact the output-       -- from a commandline. Used to limit the volatility of dependency hashes-       -- when using new-build.-       programNormaliseArgs :: Maybe Version -> PackageDescription -> [String] -> [String]-     } instance Show Program where   show (Program name _ _ _ _) = "Program: " ++ name  type ProgArg = String --- | Represents a program which has been configured and is thus ready to be run.+-- | A search path to use when locating executables. This is analogous+-- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use+-- the system default method for finding executables ('findExecutable' which+-- on unix is simply looking on the @$PATH@ but on win32 is a bit more+-- complicated). ----- These are usually made by configuring a 'Program', but if you have to--- construct one directly then start with 'simpleConfiguredProgram' and--- override any extra fields.+-- The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs+-- either before, after or instead of the default, e.g. here we add an extra+-- dir to search after the usual ones. ---data ConfiguredProgram = ConfiguredProgram {-       -- | Just the name again-       programId :: String,--       -- | The version of this program, if it is known.-       programVersion :: Maybe Version,--       -- | Default command-line args for this program.-       -- These flags will appear first on the command line, so they can be-       -- overridden by subsequent flags.-       programDefaultArgs :: [String],--       -- | Override command-line args for this program.-       -- These flags will appear last on the command line, so they override-       -- all earlier flags.-       programOverrideArgs :: [String],--       -- | Override environment variables for this program.-       -- These env vars will extend\/override the prevailing environment of-       -- the current to form the environment for the new process.-       programOverrideEnv :: [(String, Maybe String)],+-- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir]+--+-- We also use this path to set the environment when running child processes.+--+-- The @ProgramDb@ is created with a @ProgramSearchPath@ to which we+-- @prependProgramSearchPath@ to add the ones that come from cli flags and from+-- configurations. Then each of the programs that are configured in the db+-- inherits the same path as part of @configureProgram@.+type ProgramSearchPath = [ProgramSearchPathEntry] -       -- | A key-value map listing various properties of the program, useful-       -- for feature detection. Populated during the configuration step, key-       -- names depend on the specific program.-       programProperties :: Map.Map String String,+data ProgramSearchPathEntry+  = -- | A specific dir+    ProgramSearchPathDir FilePath+  | -- | The system default+    ProgramSearchPathDefault+  deriving (Show, Eq, Generic) -       -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@-       programLocation :: ProgramLocation,+instance Binary ProgramSearchPathEntry+instance Structured ProgramSearchPathEntry -       -- | In addition to the 'programLocation' where the program was found,-       -- these are additional locations that were looked at. The combination-       -- of ths found location and these not-found locations can be used to-       -- monitor to detect when the re-configuring the program might give a-       -- different result (e.g. found in a different location).-       ---       programMonitorFiles :: [FilePath]-     }-  deriving (Eq, Generic, Read, Show, Typeable)+-- | Represents a program which has been configured and is thus ready to be run.+--+-- These are usually made by configuring a 'Program', but if you have to+-- construct one directly then start with 'simpleConfiguredProgram' and+-- override any extra fields.+data ConfiguredProgram = ConfiguredProgram+  { programId :: String+  -- ^ Just the name again+  , programVersion :: Maybe Version+  -- ^ The version of this program, if it is known.+  , programDefaultArgs :: [String]+  -- ^ Default command-line args for this program.+  -- These flags will appear first on the command line, so they can be+  -- overridden by subsequent flags.+  , programOverrideArgs :: [String]+  -- ^ Override command-line args for this program.+  -- These flags will appear last on the command line, so they override+  -- all earlier flags.+  , programOverrideEnv :: [(String, Maybe String)]+  -- ^ Override environment variables for this program.+  -- These env vars will extend\/override the prevailing environment of+  -- the current to form the environment for the new process.+  , programProperties :: Map.Map String String+  -- ^ A key-value map listing various properties of the program, useful+  -- for feature detection. Populated during the configuration step, key+  -- names depend on the specific program.+  , programLocation :: ProgramLocation+  -- ^ Location of the program. eg. @\/usr\/bin\/ghc-6.4@+  , programMonitorFiles :: [FilePath]+  -- ^ In addition to the 'programLocation' where the program was found,+  -- these are additional locations that were looked at. The combination+  -- of this found location and these not-found locations can be used to+  -- monitor to detect when the re-configuring the program might give a+  -- different result (e.g. found in a different location).+  }+  deriving (Eq, Generic, Read, Show)  instance Binary ConfiguredProgram instance Structured ConfiguredProgram@@ -139,12 +154,12 @@ -- | Where a program was found. Also tells us whether it's specified by user or -- not.  This includes not just the path, but the program as well. data ProgramLocation-    = UserSpecified { locationPath :: FilePath }-      -- ^The user gave the path to this program,-      -- eg. --ghc-path=\/usr\/bin\/ghc-6.6-    | FoundOnSystem { locationPath :: FilePath }-      -- ^The program was found automatically.-      deriving (Eq, Generic, Read, Show, Typeable)+  = -- | The user gave the path to this program,+    --  eg. --ghc-path=\/usr\/bin\/ghc-6.6+    UserSpecified {locationPath :: FilePath}+  | -- | The program was found automatically.+    FoundOnSystem {locationPath :: FilePath}+  deriving (Eq, Generic, Read, Show)  instance Binary ProgramLocation instance Structured ProgramLocation@@ -155,36 +170,20 @@  -- | Suppress any extra arguments added by the user. suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram-suppressOverrideArgs prog = prog { programOverrideArgs = [] }---- | Make a simple named program.------ By default we'll just search for it in the path and not try to find the--- version name. You can override these behaviours if necessary, eg:------ > (simpleProgram "foo") { programFindLocation = ... , programFindVersion ... }----simpleProgram :: String -> Program-simpleProgram name = Program {-    programName         = name,-    programFindLocation = \v p -> findProgramOnSearchPath v p name,-    programFindVersion  = \_ _ -> return Nothing,-    programPostConf     = \_ p -> return p,-    programNormaliseArgs   = \_ _ -> id-  }+suppressOverrideArgs prog = prog{programOverrideArgs = []}  -- | Make a simple 'ConfiguredProgram'. -- -- > simpleConfiguredProgram "foo" (FoundOnSystem path)--- simpleConfiguredProgram :: String -> ProgramLocation -> ConfiguredProgram-simpleConfiguredProgram name loc = ConfiguredProgram {-     programId           = name,-     programVersion      = Nothing,-     programDefaultArgs  = [],-     programOverrideArgs = [],-     programOverrideEnv  = [],-     programProperties   = Map.empty,-     programLocation     = loc,-     programMonitorFiles = [] -- did not look in any other locations-  }+simpleConfiguredProgram name loc =+  ConfiguredProgram+    { programId = name+    , programVersion = Nothing+    , programDefaultArgs = []+    , programOverrideArgs = []+    , programOverrideEnv = []+    , programProperties = Map.empty+    , programLocation = loc+    , programMonitorFiles = [] -- did not look in any other locations+    }
src/Distribution/Simple/Register.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Register -- Copyright   :  Isaac Jones 2003-2004@@ -25,164 +27,198 @@ -- This module does not delegate anything to the per-compiler modules but just -- mixes it all in this module, which is rather unsatisfactory. The script -- generation and the unregister feature are not well used or tested.--module Distribution.Simple.Register (-    register,-    unregister,--    internalPackageDBPath,--    initPackageDB,-    doesPackageDBExist,-    createPackageDB,-    deletePackageDB,--    abiHash,-    invokeHcPkg,-    registerPackage,-    HcPkg.RegisterOptions(..),-    HcPkg.defaultRegisterOptions,-    generateRegistrationInfo,-    inplaceInstalledPackageInfo,-    absoluteInstalledPackageInfo,-    generalInstalledPackageInfo,+module Distribution.Simple.Register+  ( register+  , unregister+  , internalPackageDBPath+  , initPackageDB+  , doesPackageDBExist+  , createPackageDB+  , deletePackageDB+  , abiHash+  , invokeHcPkg+  , registerPackage+  , HcPkg.RegisterOptions (..)+  , HcPkg.defaultRegisterOptions+  , generateRegistrationInfo+  , inplaceInstalledPackageInfo+  , absoluteInstalledPackageInfo+  , generalInstalledPackageInfo   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Types.TargetInfo-import Distribution.Types.LocalBuildInfo import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.LocalBuildInfo+import Distribution.Types.TargetInfo -import Distribution.Simple.LocalBuildInfo import Distribution.Simple.BuildPaths import Distribution.Simple.BuildTarget+import Distribution.Simple.LocalBuildInfo -import qualified Distribution.Simple.GHC   as GHC+import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS-import qualified Distribution.Simple.UHC   as UHC-import qualified Distribution.Simple.HaskellSuite as HaskellSuite import qualified Distribution.Simple.PackageIndex as Index+import qualified Distribution.Simple.UHC as UHC  import Distribution.Backpack.DescribeUnitId+import Distribution.Compat.Graph (IsNode (nodeKey))+import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import qualified Distribution.InstalledPackageInfo as IPI+import Distribution.License (licenseFromSPDX, licenseToSPDX)+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Pretty import Distribution.Simple.Compiler+import Distribution.Simple.Errors+import Distribution.Simple.Flag import Distribution.Simple.Program-import Distribution.Simple.Program.Script import qualified Distribution.Simple.Program.HcPkg as HcPkg-import Distribution.Simple.Setup-import Distribution.PackageDescription-import Distribution.Package-import Distribution.License (licenseToSPDX, licenseFromSPDX)-import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import Distribution.Simple.Program.Script+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Register import Distribution.Simple.Utils-import Distribution.Utils.MapAccum import Distribution.System-import Distribution.Pretty+import Distribution.Utils.MapAccum+import Distribution.Utils.Path import Distribution.Verbosity as Verbosity import Distribution.Version-import Distribution.Compat.Graph (IsNode(nodeKey))--import System.FilePath ((</>), (<.>), isAbsolute) import System.Directory+import System.FilePath (isAbsolute)  import qualified Data.ByteString.Lazy.Char8 as BS.Char8  -- ----------------------------------------------------------------------------- -- Registration -register :: PackageDescription -> LocalBuildInfo-         -> RegisterFlags -- ^Install in the user's database?; verbose-         -> IO ()-register pkg_descr lbi0 flags =-   -- Duncan originally asked for us to not register/install files-   -- when there was no public library.  But with per-component-   -- configure, we legitimately need to install internal libraries-   -- so that we can get them.  So just unconditionally install.-   doRegister- where-  doRegister = do-    targets <- readTargetInfos verbosity pkg_descr lbi0 (regArgs flags)+register+  :: PackageDescription+  -> LocalBuildInfo+  -> RegisterFlags+  -- ^ Install in the user's database?; verbose+  -> IO ()+register 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+  targets <- readTargetInfos verbosity pkg_descr lbi0 $ registerTargets flags -    -- It's important to register in build order, because ghc-pkg-    -- will complain if a dependency is not registered.-    let componentsToRegister-            = neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets)+  -- It's important to register in build order, because ghc-pkg+  -- will complain if a dependency is not registered.+  let componentsToRegister =+        neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets) -    (_, ipi_mbs) <--        mapAccumM `flip` installedPkgs lbi0 `flip` componentsToRegister $ \index tgt ->-            case targetComponent tgt of-                CLib lib -> do-                    let clbi = targetCLBI tgt-                        lbi = lbi0 { installedPkgs = index }-                    ipi <- generateOne pkg_descr lib lbi clbi flags-                    return (Index.insert ipi index, Just ipi)-                _   -> return (index, Nothing)+  (_, ipi_mbs) <-+    mapAccumM `flip` installedPkgs lbi0 `flip` componentsToRegister $ \index tgt ->+      case targetComponent tgt of+        CLib lib -> do+          let clbi = targetCLBI tgt+              lbi = lbi0{installedPkgs = index}+          ipi <- generateOne pkg_descr lib lbi clbi flags+          return (Index.insert ipi index, Just ipi)+        _ -> return (index, Nothing) -    registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs)-   where-    verbosity = fromFlag (regVerbosity flags)+  registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs) -generateOne :: PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo-            -> RegisterFlags-            -> IO InstalledPackageInfo-generateOne pkg lib lbi clbi regFlags-  = do-    absPackageDBs    <- absolutePackageDBPaths packageDbs-    installedPkgInfo <- generateRegistrationInfo-                           verbosity pkg lib lbi clbi inplace reloc distPref-                           (registrationPackageDB absPackageDBs)+generateOne+  :: PackageDescription+  -> Library+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> RegisterFlags+  -> IO InstalledPackageInfo+generateOne pkg lib lbi clbi regFlags =+  do+    absPackageDBs <- absolutePackageDBPaths mbWorkDir packageDbs+    installedPkgInfo <-+      generateRegistrationInfo+        verbosity+        pkg+        lib+        lbi+        clbi+        inplace+        reloc+        distPref+        (registrationPackageDB absPackageDBs)     info verbosity (IPI.showInstalledPackageInfo installedPkgInfo)     return installedPkgInfo   where-    inplace   = fromFlag (regInPlace regFlags)-    reloc     = relocatable lbi+    common = registerCommonFlags regFlags+    inplace = fromFlag (regInPlace regFlags)+    reloc = relocatable lbi     -- FIXME: there's really no guarantee this will work.     -- registering into a totally different db stack can     -- fail if dependencies cannot be satisfied.-    packageDbs = nub $ withPackageDB lbi-                    ++ maybeToList (flagToMaybe  (regPackageDB regFlags))-    distPref  = fromFlag (regDistPref regFlags)-    verbosity = fromFlag (regVerbosity regFlags)+    packageDbs =+      nub $+        withPackageDB lbi+          ++ maybeToList (flagToMaybe (regPackageDB regFlags))+    distPref = fromFlag $ setupDistPref common+    verbosity = fromFlag $ setupVerbosity common+    mbWorkDir = flagToMaybe $ setupWorkingDir common -registerAll :: PackageDescription -> LocalBuildInfo -> RegisterFlags-            -> [InstalledPackageInfo]-            -> IO ()-registerAll pkg lbi regFlags ipis-  = do+registerAll+  :: PackageDescription+  -> LocalBuildInfo+  -> RegisterFlags+  -> [InstalledPackageInfo]+  -> IO ()+registerAll pkg lbi regFlags ipis =+  do     when (fromFlag (regPrintId regFlags)) $ do       for_ ipis $ \installedPkgInfo ->         -- Only print the public library's IPI-        when (packageId installedPkgInfo == packageId pkg-              && IPI.sourceLibName installedPkgInfo == LMainLibName) $-          putStrLn (prettyShow (IPI.installedUnitId installedPkgInfo))+        when+          ( packageId installedPkgInfo == packageId pkg+              && IPI.sourceLibName installedPkgInfo == LMainLibName+          )+          $ putStrLn (prettyShow (IPI.installedUnitId installedPkgInfo)) -     -- Three different modes:+    -- Three different modes:     case () of-     _ | modeGenerateRegFile   -> writeRegistrationFileOrDirectory-       | modeGenerateRegScript -> writeRegisterScript-       | otherwise             -> do-           for_ ipis $ \ipi -> do-               setupMessage' verbosity "Registering" (packageId pkg)-                 (CLibName (IPI.sourceLibName ipi))-                 (Just (IPI.instantiatedWith ipi))-               registerPackage verbosity (compiler lbi) (withPrograms lbi)-                               packageDbs ipi HcPkg.defaultRegisterOptions-+      _+        | modeGenerateRegFile -> writeRegistrationFileOrDirectory+        | modeGenerateRegScript -> writeRegisterScript+        | otherwise -> do+            for_ ipis $ \ipi -> do+              setupMessage'+                verbosity+                "Registering"+                (packageId pkg)+                (CLibName (IPI.sourceLibName ipi))+                (Just (IPI.instantiatedWith ipi))+              registerPackage+                verbosity+                (compiler lbi)+                (withPrograms lbi)+                (mbWorkDirLBI lbi)+                packageDbs+                ipi+                HcPkg.defaultRegisterOptions   where     modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))-    regFile             = fromMaybe (prettyShow (packageId pkg) <.> "conf")-                                    (fromFlag (regGenPkgConf regFlags))+    regFile =+      interpretSymbolicPathLBI lbi $+        fromMaybe+          (makeSymbolicPath (prettyShow (packageId pkg) <.> "conf"))+          (fromFlag (regGenPkgConf regFlags))      modeGenerateRegScript = fromFlag (regGenScript regFlags)      -- FIXME: there's really no guarantee this will work.     -- registering into a totally different db stack can     -- fail if dependencies cannot be satisfied.-    packageDbs = nub $ withPackageDB lbi-                    ++ maybeToList (flagToMaybe  (regPackageDB regFlags))-    verbosity = fromFlag (regVerbosity regFlags)+    packageDbs =+      nub $+        withPackageDB lbi+          ++ maybeToList (flagToMaybe (regPackageDB regFlags))+    common = registerCommonFlags regFlags+    verbosity = fromFlag (setupVerbosity common)+    mbWorkDir = mbWorkDirLBI lbi      writeRegistrationFileOrDirectory = do       -- Handles overwriting both directory and file@@ -196,195 +232,255 @@           createDirectory regFile           let num_ipis = length ipis               lpad m xs = replicate (m - length ys) '0' ++ ys-                  where ys = take m xs+                where+                  ys = take m xs               number i = lpad (length (show num_ipis)) (show i)-          for_ (zip ([1..] :: [Int]) ipis) $ \(i, installedPkgInfo) ->-            writeUTF8File (regFile </> (number i ++ "-" ++ prettyShow (IPI.installedUnitId installedPkgInfo)))-                          (IPI.showInstalledPackageInfo installedPkgInfo)+          for_ (zip ([1 ..] :: [Int]) ipis) $ \(i, installedPkgInfo) ->+            writeUTF8File+              (regFile </> (number i ++ "-" ++ prettyShow (IPI.installedUnitId installedPkgInfo)))+              (IPI.showInstalledPackageInfo installedPkgInfo)      writeRegisterScript =       case compilerFlavor (compiler lbi) of         UHC -> notice verbosity "Registration scripts not needed for uhc"-        _   -> withHcPkg verbosity-               "Registration scripts are not implemented for this compiler"-               (compiler lbi) (withPrograms lbi)-               (writeHcPkgRegisterScript verbosity ipis packageDbs)-+        _ ->+          withHcPkg+            verbosity+            "Registration scripts are not implemented for this compiler"+            (compiler lbi)+            (withPrograms lbi)+            (writeHcPkgRegisterScript verbosity mbWorkDir ipis packageDbs) -generateRegistrationInfo :: Verbosity-                         -> PackageDescription-                         -> Library-                         -> LocalBuildInfo-                         -> ComponentLocalBuildInfo-                         -> Bool-                         -> Bool-                         -> FilePath-                         -> PackageDB-                         -> IO InstalledPackageInfo+generateRegistrationInfo+  :: Verbosity+  -> PackageDescription+  -> Library+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> Bool+  -> Bool+  -> SymbolicPath Pkg (Dir Dist)+  -> PackageDB+  -> IO InstalledPackageInfo generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do-  --TODO: eliminate pwd!-  pwd <- getCurrentDirectory-+  inplaceDir <- absoluteWorkingDirLBI lbi   installedPkgInfo <-     if inplace-      -- NB: With an inplace installation, the user may run './Setup+      then -- NB: With an inplace installation, the user may run './Setup       -- build' to update the library files, without reregistering.       -- In this case, it is critical that the ABI hash not flip.-      then return (inplaceInstalledPackageInfo pwd distPref-                     pkg (mkAbiHash "inplace") lib lbi clbi)-    else do++        return+          ( inplaceInstalledPackageInfo+              inplaceDir+              distPref+              pkg+              (mkAbiHash "inplace")+              lib+              lbi+              clbi+          )+      else do         abi_hash <- abiHash verbosity pkg distPref lbi lib clbi         if reloc-          then relocRegistrationInfo verbosity-                         pkg lib lbi clbi abi_hash packageDb-          else return (absoluteInstalledPackageInfo-                         pkg abi_hash lib lbi clbi)-+          then+            relocRegistrationInfo+              verbosity+              pkg+              lib+              lbi+              clbi+              abi_hash+              packageDb+          else+            return+              ( absoluteInstalledPackageInfo+                  pkg+                  abi_hash+                  lib+                  lbi+                  clbi+              )    return installedPkgInfo  -- | Compute the 'AbiHash' of a library that we built inplace.-abiHash :: Verbosity-        -> PackageDescription-        -> FilePath-        -> LocalBuildInfo-        -> Library-        -> ComponentLocalBuildInfo-        -> IO AbiHash+abiHash+  :: Verbosity+  -> PackageDescription+  -> SymbolicPath Pkg (Dir Dist)+  -> LocalBuildInfo+  -> Library+  -> ComponentLocalBuildInfo+  -> IO AbiHash abiHash verbosity pkg distPref lbi lib clbi =-    case compilerFlavor comp of-     GHC -> do-            fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi-     GHCJS -> do-            fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi-     _ -> return (mkAbiHash "")+  case compilerFlavor comp of+    GHC -> do+      fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi+    GHCJS -> do+      fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi+    _ -> return (mkAbiHash "")   where     comp = compiler lbi-    lbi' = lbi {-              withPackageDB = withPackageDB lbi-                  ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)]-           }+    lbi' =+      lbi+        { withPackageDB =+            withPackageDB lbi+              ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)]+        } -relocRegistrationInfo :: Verbosity-                      -> PackageDescription-                      -> Library-                      -> LocalBuildInfo-                      -> ComponentLocalBuildInfo-                      -> AbiHash-                      -> PackageDB-                      -> IO InstalledPackageInfo+relocRegistrationInfo+  :: Verbosity+  -> PackageDescription+  -> Library+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> AbiHash+  -> PackageDB+  -> IO InstalledPackageInfo relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb =   case (compilerFlavor (compiler lbi)) of-    GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb-              return (relocatableInstalledPackageInfo-                        pkg abi_hash lib lbi clbi fs)-    _   -> die' verbosity-              "Distribution.Simple.Register.relocRegistrationInfo: \-               \not implemented for this compiler"+    GHC -> do+      fs <- GHC.pkgRoot verbosity lbi packageDb+      return+        ( relocatableInstalledPackageInfo+            pkg+            abi_hash+            lib+            lbi+            clbi+            fs+        )+    _ -> dieWithException verbosity RelocRegistrationInfo  initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO () initPackageDB verbosity comp progdb dbPath =-    createPackageDB verbosity comp progdb False dbPath+  createPackageDB verbosity comp progdb False dbPath  -- | Create an empty package DB at the specified location.-createPackageDB :: Verbosity -> Compiler -> ProgramDb -> Bool-                -> FilePath -> IO ()+createPackageDB+  :: Verbosity+  -> Compiler+  -> ProgramDb+  -> Bool+  -> FilePath+  -> IO () createPackageDB verbosity comp progdb preferCompat dbPath =-    case compilerFlavor comp of-      GHC   -> HcPkg.init (GHC.hcPkgInfo   progdb) verbosity preferCompat dbPath-      GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath-      UHC   -> return ()-      HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath-      _              -> die' verbosity $-                              "Distribution.Simple.Register.createPackageDB: "-                           ++ "not implemented for this compiler"+  case compilerFlavor comp of+    GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath+    GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath+    UHC -> return ()+    _ -> dieWithException verbosity CreatePackageDB  doesPackageDBExist :: FilePath -> IO Bool doesPackageDBExist dbPath = do-    -- currently one impl for all compiler flavours, but could change if needed-    dir_exists <- doesDirectoryExist dbPath-    if dir_exists-        then return True-        else doesFileExist dbPath+  -- currently one impl for all compiler flavours, but could change if needed+  dir_exists <- doesDirectoryExist dbPath+  if dir_exists+    then return True+    else doesFileExist dbPath  deletePackageDB :: FilePath -> IO () deletePackageDB dbPath = do-    -- currently one impl for all compiler flavours, but could change if needed-    dir_exists <- doesDirectoryExist dbPath-    if dir_exists-        then removeDirectoryRecursive dbPath-        else do file_exists <- doesFileExist dbPath-                when file_exists $ removeFile dbPath+  -- currently one impl for all compiler flavours, but could change if needed+  dir_exists <- doesDirectoryExist dbPath+  if dir_exists+    then removeDirectoryRecursive dbPath+    else do+      file_exists <- doesFileExist dbPath+      when file_exists $ removeFile dbPath  -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it.-invokeHcPkg :: Verbosity -> Compiler -> ProgramDb -> PackageDBStack-                -> [String] -> IO ()-invokeHcPkg verbosity comp progdb dbStack extraArgs =-  withHcPkg verbosity "invokeHcPkg" comp progdb-    (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs)+invokeHcPkg+  :: Verbosity+  -> Compiler+  -> ProgramDb+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> PackageDBStack+  -> [String]+  -> IO ()+invokeHcPkg verbosity comp progdb mbWorkDir dbStack extraArgs =+  withHcPkg+    verbosity+    "invokeHcPkg"+    comp+    progdb+    (\hpi -> HcPkg.invoke hpi verbosity mbWorkDir dbStack extraArgs) -withHcPkg :: Verbosity -> String -> Compiler -> ProgramDb-          -> (HcPkg.HcPkgInfo -> IO a) -> IO a+withHcPkg+  :: Verbosity+  -> String+  -> Compiler+  -> ProgramDb+  -> (HcPkg.HcPkgInfo -> IO a)+  -> IO a withHcPkg verbosity name comp progdb f =   case compilerFlavor comp of-    GHC   -> f (GHC.hcPkgInfo progdb)+    GHC -> f (GHC.hcPkgInfo progdb)     GHCJS -> f (GHCJS.hcPkgInfo progdb)-    _     -> die' verbosity ("Distribution.Simple.Register." ++ name ++ ":\-                  \not implemented for this compiler")+    _ -> dieWithException verbosity $ WithHcPkg name -registerPackage :: Verbosity-                -> Compiler-                -> ProgramDb-                -> PackageDBStack-                -> InstalledPackageInfo-                -> HcPkg.RegisterOptions-                -> IO ()-registerPackage verbosity comp progdb packageDbs installedPkgInfo registerOptions =+registerPackage+  :: Verbosity+  -> Compiler+  -> ProgramDb+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBStackS from+  -> InstalledPackageInfo+  -> HcPkg.RegisterOptions+  -> IO ()+registerPackage verbosity comp progdb mbWorkDir packageDbs installedPkgInfo registerOptions =   case compilerFlavor comp of-    GHC   -> GHC.registerPackage   verbosity progdb packageDbs installedPkgInfo registerOptions-    GHCJS -> GHCJS.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions-    HaskellSuite {} ->-      HaskellSuite.registerPackage verbosity      progdb packageDbs installedPkgInfo-    _ | HcPkg.registerMultiInstance registerOptions-          -> die' verbosity "Registering multiple package instances is not yet supported for this compiler"-    UHC   -> UHC.registerPackage   verbosity comp progdb packageDbs installedPkgInfo-    _    -> die' verbosity "Registering is not implemented for this compiler"+    GHC -> GHC.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions+    GHCJS -> GHCJS.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions+    _+      | HcPkg.registerMultiInstance registerOptions ->+          dieWithException verbosity RegisMultiplePkgNotSupported+    UHC -> UHC.registerPackage verbosity mbWorkDir comp progdb packageDbs installedPkgInfo+    _ -> dieWithException verbosity RegisteringNotImplemented -writeHcPkgRegisterScript :: Verbosity-                         -> [InstalledPackageInfo]-                         -> PackageDBStack-                         -> HcPkg.HcPkgInfo-                         -> IO ()-writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do+writeHcPkgRegisterScript+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> [InstalledPackageInfo]+  -> PackageDBStack+  -> HcPkg.HcPkgInfo+  -> IO ()+writeHcPkgRegisterScript verbosity mbWorkDir ipis packageDbs hpi = do   let genScript installedPkgInfo =-          let invocation  = HcPkg.registerInvocation hpi Verbosity.normal-                              packageDbs installedPkgInfo-                              HcPkg.defaultRegisterOptions-          in invocationAsSystemScript buildOS invocation+        let invocation =+              HcPkg.registerInvocation+                hpi+                Verbosity.normal+                mbWorkDir+                packageDbs+                installedPkgInfo+                HcPkg.defaultRegisterOptions+         in invocationAsSystemScript buildOS invocation       scripts = map genScript ipis       -- TODO: Do something more robust here       regScript = unlines scripts -  info verbosity ("Creating package registration script: " ++ regScriptFileName)-  writeUTF8File regScriptFileName regScript-  setFileExecutable regScriptFileName+  let out_file = interpretSymbolicPath mbWorkDir regScriptFileName+  info verbosity ("Creating package registration script: " ++ out_file)+  writeUTF8File out_file regScript+  setFileExecutable out_file -regScriptFileName :: FilePath+regScriptFileName :: SymbolicPath Pkg File regScriptFileName = case buildOS of-                        Windows -> "register.bat"-                        _       -> "register.sh"-+  Windows -> makeSymbolicPath "register.bat"+  _ -> makeSymbolicPath "register.sh"  -- ----------------------------------------------------------------------------- -- Making the InstalledPackageInfo  -- | Construct 'InstalledPackageInfo' for a library in a package, given a set -- of installation directories.--- generalInstalledPackageInfo-  :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to-                                -- absolute paths.+  :: ([FilePath] -> [FilePath])+  -- ^ Translate relative include dir paths to+  -- absolute paths.   -> PackageDescription   -> AbiHash   -> Library@@ -393,203 +489,267 @@   -> InstallDirs FilePath   -> InstalledPackageInfo generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDirs =-  IPI.InstalledPackageInfo {-    IPI.sourcePackageId    = packageId pkg,-    IPI.installedUnitId    = componentUnitId clbi,-    IPI.installedComponentId_ = componentComponentId clbi,-    IPI.instantiatedWith   = componentInstantiatedWith clbi,-    IPI.sourceLibName      = libName lib,-    IPI.compatPackageKey   = componentCompatPackageKey clbi,-    -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license-    IPI.license            =+  IPI.InstalledPackageInfo+    { IPI.sourcePackageId = packageId pkg+    , IPI.installedUnitId = componentUnitId clbi+    , IPI.installedComponentId_ = componentComponentId clbi+    , IPI.instantiatedWith = expectLibraryComponent (maybeComponentInstantiatedWith clbi)+    , IPI.sourceLibName = libName lib+    , IPI.compatPackageKey = expectLibraryComponent (maybeComponentCompatPackageKey clbi)+    , -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license+      IPI.license =         if ghc84-        then Left $ either id licenseToSPDX $ licenseRaw pkg-        else Right $ either licenseFromSPDX id $ licenseRaw pkg,-    IPI.copyright          = copyright   pkg,-    IPI.maintainer         = maintainer  pkg,-    IPI.author             = author      pkg,-    IPI.stability          = stability   pkg,-    IPI.homepage           = homepage    pkg,-    IPI.pkgUrl             = pkgUrl      pkg,-    IPI.synopsis           = synopsis    pkg,-    IPI.description        = description pkg,-    IPI.category           = category    pkg,-    IPI.abiHash            = abi_hash,-    IPI.indefinite         = componentIsIndefinite clbi,-    IPI.exposed            = libExposed  lib,-    IPI.exposedModules     = componentExposedModules clbi-                             -- add virtual modules into the list of exposed modules for the-                             -- package database as well.-                             ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi),-    IPI.hiddenModules      = otherModules bi,-    IPI.trusted            = IPI.trusted IPI.emptyInstalledPackageInfo,-    IPI.importDirs         = [ libdir installDirs | hasModules ],-    IPI.libraryDirs        = libdirs,-    IPI.libraryDynDirs     = dynlibdirs,-    IPI.dataDir            = datadir installDirs,-    IPI.hsLibraries        = (if hasLibrary-                              then [getHSLibraryName (componentUnitId clbi)]-                              else []) ++ extraBundledLibs bi,-    IPI.extraLibraries     = extraLibs bi,-    IPI.extraGHCiLibraries = extraGHCiLibs bi,-    IPI.includeDirs        = absinc ++ adjustRelIncDirs relinc,-    IPI.includes           = includes bi,-    IPI.depends            = depends,-    IPI.abiDepends         = [], -- due to #5465-    IPI.ccOptions          = [], -- Note. NOT ccOptions bi!-                                 -- We don't want cc-options to be propagated-                                 -- to C compilations in other packages.-    IPI.cxxOptions         = [], -- Also. NOT cxxOptions bi!-    IPI.ldOptions          = ldOptions bi,-    IPI.frameworks         = frameworks bi,-    IPI.frameworkDirs      = extraFrameworkDirs bi,-    IPI.haddockInterfaces  = [haddockdir installDirs </> haddockName pkg],-    IPI.haddockHTMLs       = [htmldir installDirs],-    IPI.pkgRoot            = Nothing,-    IPI.libVisibility      = libVisibility lib-  }+          then Left $ either id licenseToSPDX $ licenseRaw pkg+          else Right $ either licenseFromSPDX id $ licenseRaw pkg+    , IPI.copyright = copyright pkg+    , IPI.maintainer = maintainer pkg+    , IPI.author = author pkg+    , IPI.stability = stability pkg+    , IPI.homepage = homepage pkg+    , IPI.pkgUrl = pkgUrl pkg+    , IPI.synopsis = synopsis pkg+    , IPI.description = description pkg+    , IPI.category = category pkg+    , IPI.abiHash = abi_hash+    , IPI.indefinite = componentIsIndefinite clbi+    , IPI.exposed = libExposed lib+    , IPI.exposedModules =+        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)+    , IPI.hiddenModules = otherModules bi+    , IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo+    , IPI.importDirs = [libdir installDirs | hasModules]+    , IPI.libraryDirs = libdirs+    , IPI.libraryDirsStatic = libdirsStatic+    , IPI.libraryDynDirs = dynlibdirs+    , IPI.dataDir = datadir installDirs+    , IPI.hsLibraries =+        ( if hasLibrary+            then [getHSLibraryName (componentUnitId clbi)]+            else []+        )+          ++ extraBundledLibs bi+    , IPI.extraLibraries = extraLibs bi+    , IPI.extraLibrariesStatic = extraLibsStatic bi+    , IPI.extraGHCiLibraries = extraGHCiLibs bi+    , IPI.includeDirs = absinc ++ adjustRelIncDirs relinc+    , IPI.includes = map getSymbolicPath $ includes bi+    , IPI.depends = depends+    , IPI.abiDepends = [] -- due to #5465+    , IPI.ccOptions = [] -- Note. NOT ccOptions bi!+    -- We don't want cc-options to be propagated+    -- to C compilations in other packages.+    , IPI.cxxOptions = [] -- Also. NOT cxxOptions bi!+    , IPI.ldOptions = ldOptions bi+    , IPI.frameworks = map getSymbolicPath $ frameworks bi+    , IPI.frameworkDirs = map getSymbolicPath $ extraFrameworkDirs bi+    , IPI.haddockInterfaces = [haddockdir installDirs </> haddockLibraryPath pkg lib | hasModules]+    , IPI.haddockHTMLs = [htmldir installDirs | hasModules]+    , IPI.pkgRoot = Nothing+    , IPI.libVisibility = libVisibility lib+    }   where     ghc84 = case compilerId $ compiler lbi of-        CompilerId GHC v -> v >= mkVersion [8, 4]-        _                -> False+      CompilerId GHC v -> v >= mkVersion [8, 4]+      _ -> False      bi = libBuildInfo lib-    --TODO: unclear what the root cause of the+    -- TODO: unclear what the root cause of the     -- duplication is, but we nub it here for now:     depends = ordNub $ map fst (componentPackageDeps clbi)-    (absinc, relinc) = partition isAbsolute (includeDirs bi)+    (absinc, relinc) = partition isAbsolute (map getSymbolicPath $ includeDirs bi)     hasModules = not $ null (allLibModules lib clbi)     comp = compiler lbi-    hasLibrary = (hasModules || not (null (cSources bi))-                             || not (null (asmSources bi))-                             || not (null (cmmSources bi))-                             || not (null (cxxSources bi))-                             || (not (null (jsSources bi)) &&-                                compilerFlavor comp == GHCJS))-               && not (componentIsIndefinite clbi)+    hasLibrary =+      ( hasModules+          || not (null (cSources bi))+          || not (null (asmSources bi))+          || not (null (cmmSources bi))+          || not (null (cxxSources bi))+          || (not (null (jsSources bi)) && hasJsSupport)+      )+        && not (componentIsIndefinite clbi)+    hasJsSupport = case hostPlatform lbi of+      Platform JavaScript _ -> True+      _ -> False+    extraLibDirs' = map getSymbolicPath $ extraLibDirs bi+    libdirsStatic+      | hasLibrary = libdir installDirs : extraLibDirsStaticOrFallback+      | otherwise = extraLibDirsStaticOrFallback+      where+        -- If no static library dirs were given, the package likely makes no+        -- distinction between fully static linking and otherwise.+        -- Fall back to the normal library dirs in that case.+        extraLibDirsStaticOrFallback = case extraLibDirsStatic bi of+          [] -> extraLibDirs'+          dirs -> map getSymbolicPath dirs     (libdirs, dynlibdirs)-      | not hasLibrary-      = (extraLibDirs bi, [])+      | not hasLibrary =+          (extraLibDirs', [])       -- the dynamic-library-dirs defaults to the library-dirs if not specified,       -- so this works whether the dynamic-library-dirs field is supported or not -      | libraryDynDirSupported comp-      = (libdir    installDirs : extraLibDirs bi,-         dynlibdir installDirs : extraLibDirs bi)+      | libraryDynDirSupported comp =+          ( libdir installDirs : extraLibDirs'+          , dynlibdir installDirs : extraLibDirs'+          )+      | otherwise =+          (libdir installDirs : dynlibdir installDirs : extraLibDirs', [])+    expectLibraryComponent (Just attribute) = attribute+    expectLibraryComponent Nothing = (error "generalInstalledPackageInfo: Expected a library component, got something else.") -      | otherwise-      = (libdir installDirs : dynlibdir installDirs : extraLibDirs bi, [])-      -- the compiler doesn't understand the dynamic-library-dirs field so we-      -- add the dyn directory to the "normal" list in the library-dirs field+-- the compiler doesn't understand the dynamic-library-dirs field so we+-- add the dyn directory to the "normal" list in the library-dirs field  -- | Construct 'InstalledPackageInfo' for a library that is in place in the -- build tree. -- -- This function knows about the layout of in place packages.----inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree-                            -> FilePath -- ^ location of the dist tree-                            -> PackageDescription-                            -> AbiHash-                            -> Library-                            -> LocalBuildInfo-                            -> ComponentLocalBuildInfo-                            -> InstalledPackageInfo+inplaceInstalledPackageInfo+  :: AbsolutePath (Dir Pkg)+  -> SymbolicPath Pkg (Dir Dist)+  -- ^ location of the dist tree+  -> PackageDescription+  -> AbiHash+  -> Library+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> InstalledPackageInfo inplaceInstalledPackageInfo inplaceDir distPref pkg abi_hash lib lbi clbi =-    generalInstalledPackageInfo adjustRelativeIncludeDirs-                                pkg abi_hash lib lbi clbi installDirs+  generalInstalledPackageInfo+    adjustRelativeIncludeDirs+    pkg+    abi_hash+    lib+    lbi+    clbi+    installDirs   where+    i = interpretSymbolicPathAbsolute inplaceDir -- See Note [Symbolic paths] in Distribution.Utils.Path     adjustRelativeIncludeDirs = concatMap $ \d ->-      [ inplaceDir </> d                    -- local include-dir-      , inplaceDir </> libTargetDir </> d   -- autogen include-dir+      [ i $ makeRelativePathEx d -- local include-dir+      , i $ libTargetDir </> makeRelativePathEx d -- autogen include-dir       ]     libTargetDir = componentBuildDir lbi clbi     installDirs =-      (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) {-        libdir     = inplaceDir </> libTargetDir,-        dynlibdir  = inplaceDir </> libTargetDir,-        datadir    = inplaceDir </> dataDir pkg,-        docdir     = inplaceDocdir,-        htmldir    = inplaceHtmldir,-        haddockdir = inplaceHtmldir-      }-    inplaceDocdir  = inplaceDir </> distPref </> "doc"-    inplaceHtmldir = inplaceDocdir </> "html" </> prettyShow (packageName pkg)-+      (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest)+        { libdir = i libTargetDir+        , dynlibdir = i libTargetDir+        , datadir =+            let rawDataDir = dataDir pkg+             in if null $ getSymbolicPath rawDataDir+                  then i sameDirectory+                  else i rawDataDir+        , docdir = i inplaceDocdir+        , htmldir = inplaceHtmldir+        , haddockdir = inplaceHtmldir+        }+    inplaceDocdir = distPref </> makeRelativePathEx "doc"+    inplaceHtmldir = i $ inplaceDocdir </> makeRelativePathEx ("html" </> prettyShow (packageName pkg))  -- | Construct 'InstalledPackageInfo' for the final install location of a -- library package. -- -- This function knows about the layout of installed packages.----absoluteInstalledPackageInfo :: PackageDescription-                             -> AbiHash-                             -> Library-                             -> LocalBuildInfo-                             -> ComponentLocalBuildInfo-                             -> InstalledPackageInfo+absoluteInstalledPackageInfo+  :: PackageDescription+  -> AbiHash+  -> Library+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> InstalledPackageInfo absoluteInstalledPackageInfo pkg abi_hash lib lbi clbi =-    generalInstalledPackageInfo adjustReativeIncludeDirs-                                pkg abi_hash lib lbi clbi installDirs+  generalInstalledPackageInfo+    adjustReativeIncludeDirs+    pkg+    abi_hash+    lib+    lbi+    clbi+    installDirs   where     -- For installed packages we install all include files into one dir,     -- whereas in the build tree they may live in multiple local dirs.     adjustReativeIncludeDirs _       | null (installIncludes bi) = []-      | otherwise                 = [includedir installDirs]+      | otherwise = [includedir installDirs]     bi = libBuildInfo lib     installDirs = absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest --relocatableInstalledPackageInfo :: PackageDescription-                                -> AbiHash-                                -> Library-                                -> LocalBuildInfo-                                -> ComponentLocalBuildInfo-                                -> FilePath-                                -> InstalledPackageInfo+relocatableInstalledPackageInfo+  :: PackageDescription+  -> AbiHash+  -> Library+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> SymbolicPath CWD ('Dir Pkg)+  -> InstalledPackageInfo relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi pkgroot =-    generalInstalledPackageInfo adjustReativeIncludeDirs-                                pkg abi_hash lib lbi clbi installDirs+  generalInstalledPackageInfo+    adjustReativeIncludeDirs+    pkg+    abi_hash+    lib+    lbi+    clbi+    installDirs   where     -- For installed packages we install all include files into one dir,     -- whereas in the build tree they may live in multiple local dirs.     adjustReativeIncludeDirs _       | null (installIncludes bi) = []-      | otherwise                 = [includedir installDirs]+      | otherwise = [includedir installDirs]     bi = libBuildInfo lib -    installDirs = fmap (("${pkgroot}" </>) . shortRelativePath pkgroot)-                $ absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest+    installDirs =+      fmap (("${pkgroot}" </>) . shortRelativePath (getSymbolicPath pkgroot)) $+        absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest  -- ----------------------------------------------------------------------------- -- Unregistration  unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () unregister pkg lbi regFlags = do-  let pkgid     = packageId pkg+  let pkgid = packageId pkg+      common = registerCommonFlags regFlags       genScript = fromFlag (regGenScript regFlags)-      verbosity = fromFlag (regVerbosity regFlags)-      packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi))-                                    (regPackageDB regFlags)+      verbosity = fromFlag (setupVerbosity common)+      packageDb =+        fromFlagOrDefault+          (registrationPackageDB (withPackageDB lbi))+          (regPackageDB regFlags)+      mbWorkDir = mbWorkDirLBI lbi       unreg hpi =-        let invocation = HcPkg.unregisterInvocation-                           hpi Verbosity.normal packageDb pkgid-        in if genScript-             then writeFileAtomic unregScriptFileName-                    (BS.Char8.pack $ invocationAsSystemScript buildOS invocation)-             else runProgramInvocation verbosity invocation+        let invocation =+              HcPkg.unregisterInvocation+                hpi+                Verbosity.normal+                mbWorkDir+                packageDb+                pkgid+         in if genScript+              then+                writeFileAtomic+                  unregScriptFileName+                  (BS.Char8.pack $ invocationAsSystemScript buildOS invocation)+              else runProgramInvocation verbosity invocation   setupMessage verbosity "Unregistering" pkgid-  withHcPkg verbosity "unregistering is only implemented for GHC and GHCJS"-    (compiler lbi) (withPrograms lbi) unreg+  withHcPkg+    verbosity+    "unregistering is only implemented for GHC and GHCJS"+    (compiler lbi)+    (withPrograms lbi)+    unreg  unregScriptFileName :: FilePath unregScriptFileName = case buildOS of-                          Windows -> "unregister.bat"-                          _       -> "unregister.sh"+  Windows -> "unregister.bat"+  _ -> "unregister.sh" -internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath+internalPackageDBPath :: LocalBuildInfo -> SymbolicPath Pkg (Dir Dist) -> SymbolicPath Pkg (Dir PkgDB) internalPackageDBPath lbi distPref =-      case compilerFlavor (compiler lbi) of-        UHC -> UHC.inplacePackageDbPath lbi-        _   -> distPref </> "package.conf.inplace"+  case compilerFlavor (compiler lbi) of+    UHC -> UHC.inplacePackageDbPath lbi+    _ -> distPref </> makeRelativePathEx "package.conf.inplace"
src/Distribution/Simple/Setup.hs view
@@ -1,2348 +1,251 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Setup--- Copyright   :  Isaac Jones 2003-2004---                Duncan Coutts 2007--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This is a big module, but not very complicated. The code is very regular--- and repetitive. It defines the command line interface for all the Cabal--- commands. For each command (like @configure@, @build@ etc) it defines a type--- that holds all the flags, the default set of flags and a 'CommandUI' that--- maps command line flags to and from the corresponding flags type.------ All the flags types are instances of 'Monoid', see--- <http://www.haskell.org/pipermail/cabal-devel/2007-December/001509.html>--- for an explanation.------ The types defined here get used in the front end and especially in--- @cabal-install@ which has to do quite a bit of manipulating sets of command--- line flags.------ This is actually relatively nice, it works quite well. The main change it--- needs is to unify it with the code for managing sets of fields that can be--- read and written from files. This would allow us to save configure flags in--- config files.--module Distribution.Simple.Setup (--  GlobalFlags(..),   emptyGlobalFlags,   defaultGlobalFlags,   globalCommand,-  ConfigFlags(..),   emptyConfigFlags,   defaultConfigFlags,   configureCommand,-  configPrograms,-  configAbsolutePaths, readPackageDbList, showPackageDbList,-  CopyFlags(..),     emptyCopyFlags,     defaultCopyFlags,     copyCommand,-  InstallFlags(..),  emptyInstallFlags,  defaultInstallFlags,  installCommand,-  HaddockTarget(..),-  HaddockFlags(..),  emptyHaddockFlags,  defaultHaddockFlags,  haddockCommand,-  HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,-  BuildFlags(..),    emptyBuildFlags,    defaultBuildFlags,    buildCommand,-  ShowBuildInfoFlags(..),                defaultShowBuildFlags, showBuildInfoCommand,-  ReplFlags(..),                         defaultReplFlags,     replCommand,-  CleanFlags(..),    emptyCleanFlags,    defaultCleanFlags,    cleanCommand,-  RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand,-                                                               unregisterCommand,-  SDistFlags(..),    emptySDistFlags,    defaultSDistFlags,    sdistCommand,-  TestFlags(..),     emptyTestFlags,     defaultTestFlags,     testCommand,-  TestShowDetails(..),-  BenchmarkFlags(..), emptyBenchmarkFlags,-  defaultBenchmarkFlags, benchmarkCommand,-  CopyDest(..),-  configureArgs, configureOptions, configureCCompiler, configureLinker,-  buildOptions, haddockOptions, installDirsOptions,-  testOptions', benchmarkOptions',-  programDbOptions, programDbPaths',-  programFlagsDescription,-  replOptions,-  splitArgs,--  defaultDistPref, optionDistPref,--  Flag(..),-  toFlag,-  fromFlag,-  fromFlagOrDefault,-  flagToMaybe,-  flagToList,-  maybeToFlag,-  BooleanFlag(..),-  boolOpt, boolOpt', trueArg, falseArg,-  optionVerbosity, optionNumJobs) where--import Prelude ()-import Distribution.Compat.Prelude hiding (get)--import Distribution.Compiler-import Distribution.ReadE-import Distribution.Parsec-import Distribution.Pretty-import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp-import Distribution.ModuleName-import Distribution.PackageDescription-import Distribution.Simple.Command hiding (boolOpt, boolOpt')-import qualified Distribution.Simple.Command as Command-import Distribution.Simple.Compiler-import Distribution.Simple.Flag-import Distribution.Simple.Utils-import Distribution.Simple.Program-import Distribution.Simple.InstallDirs-import Distribution.Verbosity-import Distribution.Utils.NubList-import Distribution.Types.ComponentId-import Distribution.Types.GivenComponent-import Distribution.Types.Module-import Distribution.Types.PackageVersionConstraint--import Distribution.Compat.Stack-import Distribution.Compat.Semigroup (Last' (..), Option' (..))---- FIXME Not sure where this should live-defaultDistPref :: FilePath-defaultDistPref = "dist"---- --------------------------------------------------------------- * Global flags--- ---------------------------------------------------------------- In fact since individual flags types are monoids and these are just sets of--- flags then they are also monoids pointwise. This turns out to be really--- useful. The mempty is the set of empty flags and mappend allows us to--- override specific flags. For example we can start with default flags and--- override with the ones we get from a file or the command line, or both.---- | Flags that apply at the top level, not to any sub-command.-data GlobalFlags = GlobalFlags {-    globalVersion        :: Flag Bool,-    globalNumericVersion :: Flag Bool-  } deriving (Generic, Typeable)--defaultGlobalFlags :: GlobalFlags-defaultGlobalFlags  = GlobalFlags {-    globalVersion        = Flag False,-    globalNumericVersion = Flag False-  }--globalCommand :: [Command action] -> CommandUI GlobalFlags-globalCommand commands = CommandUI-  { commandName         = ""-  , commandSynopsis     = ""-  , commandUsage        = \pname ->-         "This Setup program uses the Haskell Cabal Infrastructure.\n"-      ++ "See http://www.haskell.org/cabal/ for more information.\n"-      ++ "\n"-      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n"-  , commandDescription = Just $ \pname ->-      let-        commands' = commands ++ [commandAddAction helpCommandUI undefined]-        cmdDescs = getNormalCommandDescriptions commands'-        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]-        align str = str ++ replicate (maxlen - length str) ' '-      in-         "Commands:\n"-      ++ unlines [ "  " ++ align name ++ "    " ++ descr-                 | (name, descr) <- cmdDescs ]-      ++ "\n"-      ++ "For more information about a command use\n"-      ++ "  " ++ pname ++ " COMMAND --help\n\n"-      ++ "Typical steps for installing Cabal packages:\n"-      ++ concat [ "  " ++ pname ++ " " ++ x ++ "\n"-                | x <- ["configure", "build", "install"]]-  , commandNotes        = Nothing-  , commandDefaultFlags = defaultGlobalFlags-  , commandOptions      = \_ ->-      [option ['V'] ["version"]-         "Print version information"-         globalVersion (\v flags -> flags { globalVersion = v })-         trueArg-      ,option [] ["numeric-version"]-         "Print just the version number"-         globalNumericVersion (\v flags -> flags { globalNumericVersion = v })-         trueArg-      ]-  }--emptyGlobalFlags :: GlobalFlags-emptyGlobalFlags = mempty--instance Monoid GlobalFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup GlobalFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * Config flags--- ---------------------------------------------------------------- | Flags to @configure@ command.------ IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags'--- should be updated.--- IMPORTANT: every time a new flag is added, it should be added to the Eq instance-data ConfigFlags = ConfigFlags {-    -- This is the same hack as in 'buildArgs' and 'copyArgs'.-    -- TODO: Stop using this eventually when 'UserHooks' gets changed-    configArgs :: [String],--    --FIXME: the configPrograms is only here to pass info through to configure-    -- because the type of configure is constrained by the UserHooks.-    -- when we change UserHooks next we should pass the initial-    -- ProgramDb directly and not via ConfigFlags-    configPrograms_     :: Option' (Last' ProgramDb), -- ^All programs that-                                                      -- @cabal@ may run--    configProgramPaths  :: [(String, FilePath)], -- ^user specified programs paths-    configProgramArgs   :: [(String, [String])], -- ^user specified programs args-    configProgramPathExtra :: NubList FilePath,  -- ^Extend the $PATH-    configHcFlavor      :: Flag CompilerFlavor, -- ^The \"flavor\" of the-                                                -- compiler, e.g. GHC.-    configHcPath        :: Flag FilePath, -- ^given compiler location-    configHcPkg         :: Flag FilePath, -- ^given hc-pkg location-    configVanillaLib    :: Flag Bool,     -- ^Enable vanilla library-    configProfLib       :: Flag Bool,     -- ^Enable profiling in the library-    configSharedLib     :: Flag Bool,     -- ^Build shared library-    configStaticLib     :: Flag Bool,     -- ^Build static library-    configDynExe        :: Flag Bool,     -- ^Enable dynamic linking of the-                                          -- executables.-    configFullyStaticExe :: Flag Bool,     -- ^Enable fully static linking of the-                                          -- executables.-    configProfExe       :: Flag Bool,     -- ^Enable profiling in the-                                          -- executables.-    configProf          :: Flag Bool,     -- ^Enable profiling in the library-                                          -- and executables.-    configProfDetail    :: Flag ProfDetailLevel, -- ^Profiling detail level-                                          --  in the library and executables.-    configProfLibDetail :: Flag ProfDetailLevel, -- ^Profiling  detail level-                                                 -- in the library-    configConfigureArgs :: [String],      -- ^Extra arguments to @configure@-    configOptimization  :: Flag OptimisationLevel,  -- ^Enable optimization.-    configProgPrefix    :: Flag PathTemplate, -- ^Installed executable prefix.-    configProgSuffix    :: Flag PathTemplate, -- ^Installed executable suffix.-    configInstallDirs   :: InstallDirs (Flag PathTemplate), -- ^Installation-                                                            -- paths-    configScratchDir    :: Flag FilePath,-    configExtraLibDirs  :: [FilePath],   -- ^ path to search for extra libraries-    configExtraFrameworkDirs :: [FilePath],   -- ^ path to search for extra-                                              -- frameworks (OS X only)-    configExtraIncludeDirs :: [FilePath],   -- ^ path to search for header files-    configIPID          :: Flag String, -- ^ explicit IPID to be used-    configCID           :: Flag ComponentId, -- ^ explicit CID to be used-    configDeterministic :: Flag Bool, -- ^ be as deterministic as possible-                                      -- (e.g., invariant over GHC, database,-                                      -- etc).  Used by the test suite--    configDistPref :: Flag FilePath, -- ^"dist" prefix-    configCabalFilePath :: Flag FilePath, -- ^ Cabal file to use-    configVerbosity :: Flag Verbosity, -- ^verbosity level-    configUserInstall :: Flag Bool,    -- ^The --user\/--global flag-    configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use-    configGHCiLib   :: Flag Bool,      -- ^Enable compiling library for GHCi-    configSplitSections :: Flag Bool,      -- ^Enable -split-sections with GHC-    configSplitObjs :: Flag Bool,      -- ^Enable -split-objs with GHC-    configStripExes :: Flag Bool,      -- ^Enable executable stripping-    configStripLibs :: Flag Bool,      -- ^Enable library stripping-    configConstraints :: [PackageVersionConstraint], -- ^Additional constraints for-                                                     -- dependencies.-    configDependencies :: [GivenComponent],-      -- ^The packages depended on.-    configInstantiateWith :: [(ModuleName, Module)],-      -- ^ The requested Backpack instantiation.  If empty, either this-      -- package does not use Backpack, or we just want to typecheck-      -- the indefinite package.-    configConfigurationsFlags :: FlagAssignment,-    configTests               :: Flag Bool, -- ^Enable test suite compilation-    configBenchmarks          :: Flag Bool, -- ^Enable benchmark compilation-    configCoverage :: Flag Bool, -- ^Enable program coverage-    configLibCoverage :: Flag Bool, -- ^Enable program coverage (deprecated)-    configExactConfiguration  :: Flag Bool,-      -- ^All direct dependencies and flags are provided on the command line by-      -- the user via the '--dependency' and '--flags' options.-    configFlagError :: Flag String,-      -- ^Halt and show an error message indicating an error in flag assignment-    configRelocatable :: Flag Bool, -- ^ Enable relocatable package built-    configDebugInfo :: Flag DebugInfoLevel,  -- ^ Emit debug info.-    configUseResponseFiles :: Flag Bool,-      -- ^ Whether to use response files at all. They're used for such tools-      -- as haddock, or ld.-    configAllowDependingOnPrivateLibs :: Flag Bool-      -- ^ Allow depending on private sublibraries. This is used by external-      -- tools (like cabal-install) so they can add multiple-public-libraries-      -- compatibility to older ghcs by checking visibility externally.-  }-  deriving (Generic, Read, Show, Typeable)--instance Binary ConfigFlags-instance Structured ConfigFlags---- | More convenient version of 'configPrograms'. Results in an--- 'error' if internal invariant is violated.-configPrograms :: WithCallStack (ConfigFlags -> ProgramDb)-configPrograms = fromMaybe (error "FIXME: remove configPrograms") . fmap getLast'-               . getOption' . configPrograms_--instance Eq ConfigFlags where-  (==) a b =-    -- configPrograms skipped: not user specified, has no Eq instance-    equal configProgramPaths-    && equal configProgramArgs-    && equal configProgramPathExtra-    && equal configHcFlavor-    && equal configHcPath-    && equal configHcPkg-    && equal configVanillaLib-    && equal configProfLib-    && equal configSharedLib-    && equal configStaticLib-    && equal configDynExe-    && equal configFullyStaticExe-    && equal configProfExe-    && equal configProf-    && equal configProfDetail-    && equal configProfLibDetail-    && equal configConfigureArgs-    && equal configOptimization-    && equal configProgPrefix-    && equal configProgSuffix-    && equal configInstallDirs-    && equal configScratchDir-    && equal configExtraLibDirs-    && equal configExtraIncludeDirs-    && equal configIPID-    && equal configDeterministic-    && equal configDistPref-    && equal configVerbosity-    && equal configUserInstall-    && equal configPackageDBs-    && equal configGHCiLib-    && equal configSplitSections-    && equal configSplitObjs-    && equal configStripExes-    && equal configStripLibs-    && equal configConstraints-    && equal configDependencies-    && equal configConfigurationsFlags-    && equal configTests-    && equal configBenchmarks-    && equal configCoverage-    && equal configLibCoverage-    && equal configExactConfiguration-    && equal configFlagError-    && equal configRelocatable-    && equal configDebugInfo-    && equal configUseResponseFiles-    where-      equal f = on (==) f a b--configAbsolutePaths :: ConfigFlags -> IO ConfigFlags-configAbsolutePaths f =-  (\v -> f { configPackageDBs = v })-  `liftM` traverse (maybe (return Nothing) (liftM Just . absolutePackageDBPath))-  (configPackageDBs f)--defaultConfigFlags :: ProgramDb -> ConfigFlags-defaultConfigFlags progDb = emptyConfigFlags {-    configArgs         = [],-    configPrograms_    = Option' (Just (Last' progDb)),-    configHcFlavor     = maybe NoFlag Flag defaultCompilerFlavor,-    configVanillaLib   = Flag True,-    configProfLib      = NoFlag,-    configSharedLib    = NoFlag,-    configStaticLib    = NoFlag,-    configDynExe       = Flag False,-    configFullyStaticExe = Flag False,-    configProfExe      = NoFlag,-    configProf         = NoFlag,-    configProfDetail   = NoFlag,-    configProfLibDetail= NoFlag,-    configOptimization = Flag NormalOptimisation,-    configProgPrefix   = Flag (toPathTemplate ""),-    configProgSuffix   = Flag (toPathTemplate ""),-    configDistPref     = NoFlag,-    configCabalFilePath = NoFlag,-    configVerbosity    = Flag normal,-    configUserInstall  = Flag False,           --TODO: reverse this-#if defined(mingw32_HOST_OS)-    -- See #1589.-    configGHCiLib      = Flag True,-#else-    configGHCiLib      = NoFlag,-#endif-    configSplitSections = Flag False,-    configSplitObjs    = Flag False, -- takes longer, so turn off by default-    configStripExes    = NoFlag,-    configStripLibs    = NoFlag,-    configTests        = Flag False,-    configBenchmarks   = Flag False,-    configCoverage     = Flag False,-    configLibCoverage  = NoFlag,-    configExactConfiguration = Flag False,-    configFlagError    = NoFlag,-    configRelocatable  = Flag False,-    configDebugInfo    = Flag NoDebugInfo,-    configUseResponseFiles = NoFlag-  }--configureCommand :: ProgramDb -> CommandUI ConfigFlags-configureCommand progDb = CommandUI-  { commandName         = "configure"-  , commandSynopsis     = "Prepare to build the package."-  , commandDescription  = Just $ \_ -> wrapText $-         "Configure how the package is built by setting "-      ++ "package (and other) flags.\n"-      ++ "\n"-      ++ "The configuration affects several other commands, "-      ++ "including build, test, bench, run, repl.\n"-  , commandNotes        = Just $ \_pname -> programFlagsDescription progDb-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " configure [FLAGS]\n"-  , commandDefaultFlags = defaultConfigFlags progDb-  , commandOptions      = \showOrParseArgs ->-         configureOptions showOrParseArgs-      ++ programDbPaths   progDb showOrParseArgs-           configProgramPaths (\v fs -> fs { configProgramPaths = v })-      ++ programDbOption progDb showOrParseArgs-           configProgramArgs (\v fs -> fs { configProgramArgs = v })-      ++ programDbOptions progDb showOrParseArgs-           configProgramArgs (\v fs -> fs { configProgramArgs = v })-  }---- | Inverse to 'dispModSubstEntry'.-parsecModSubstEntry :: ParsecParser (ModuleName, Module)-parsecModSubstEntry = do-    k <- parsec-    _ <- P.char '='-    v <- parsec-    return (k, v)---- | Pretty-print a single entry of a module substitution.-dispModSubstEntry :: (ModuleName, Module) -> Disp.Doc-dispModSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v--configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags]-configureOptions showOrParseArgs =-      [optionVerbosity configVerbosity-       (\v flags -> flags { configVerbosity = v })-      ,optionDistPref-         configDistPref (\d flags -> flags { configDistPref = d })-         showOrParseArgs--      ,option [] ["compiler"] "compiler"-         configHcFlavor (\v flags -> flags { configHcFlavor = v })-         (choiceOpt [ (Flag GHC,   ("g", ["ghc"]),   "compile with GHC")-                    , (Flag GHCJS, ([] , ["ghcjs"]), "compile with GHCJS")-                    , (Flag UHC,   ([] , ["uhc"]),   "compile with UHC")-                    -- "haskell-suite" compiler id string will be replaced-                    -- by a more specific one during the configure stage-                    , (Flag (HaskellSuite "haskell-suite"), ([] , ["haskell-suite"]),-                        "compile with a haskell-suite compiler")])--      ,option "" ["cabal-file"]-         "use this Cabal file"-         configCabalFilePath (\v flags -> flags { configCabalFilePath = v })-         (reqArgFlag "PATH")--      ,option "w" ["with-compiler"]-         "give the path to a particular compiler"-         configHcPath (\v flags -> flags { configHcPath = v })-         (reqArgFlag "PATH")--      ,option "" ["with-hc-pkg"]-         "give the path to the package tool"-         configHcPkg (\v flags -> flags { configHcPkg = v })-         (reqArgFlag "PATH")-      ]-   ++ map liftInstallDirs installDirsOptions-   ++ [option "" ["program-prefix"]-          "prefix to be applied to installed executables"-          configProgPrefix-          (\v flags -> flags { configProgPrefix = v })-          (reqPathTemplateArgFlag "PREFIX")--      ,option "" ["program-suffix"]-          "suffix to be applied to installed executables"-          configProgSuffix (\v flags -> flags { configProgSuffix = v } )-          (reqPathTemplateArgFlag "SUFFIX")--      ,option "" ["library-vanilla"]-         "Vanilla libraries"-         configVanillaLib (\v flags -> flags { configVanillaLib = v })-         (boolOpt [] [])--      ,option "p" ["library-profiling"]-         "Library profiling"-         configProfLib (\v flags -> flags { configProfLib = v })-         (boolOpt "p" [])--      ,option "" ["shared"]-         "Shared library"-         configSharedLib (\v flags -> flags { configSharedLib = v })-         (boolOpt [] [])--      ,option "" ["static"]-         "Static library"-         configStaticLib (\v flags -> flags { configStaticLib = v })-         (boolOpt [] [])--      ,option "" ["executable-dynamic"]-         "Executable dynamic linking"-         configDynExe (\v flags -> flags { configDynExe = v })-         (boolOpt [] [])--      ,option "" ["executable-static"]-         "Executable fully static linking"-         configFullyStaticExe (\v flags -> flags { configFullyStaticExe = v })-         (boolOpt [] [])--      ,option "" ["profiling"]-         "Executable and library profiling"-         configProf (\v flags -> flags { configProf = v })-         (boolOpt [] [])--      ,option "" ["executable-profiling"]-         "Executable profiling (DEPRECATED)"-         configProfExe (\v flags -> flags { configProfExe = v })-         (boolOpt [] [])--      ,option "" ["profiling-detail"]-         ("Profiling detail level for executable and library (default, " ++-          "none, exported-functions, toplevel-functions,  all-functions).")-         configProfDetail (\v flags -> flags { configProfDetail = v })-         (reqArg' "level" (Flag . flagToProfDetailLevel)-                          showProfDetailLevelFlag)--      ,option "" ["library-profiling-detail"]-         "Profiling detail level for libraries only."-         configProfLibDetail (\v flags -> flags { configProfLibDetail = v })-         (reqArg' "level" (Flag . flagToProfDetailLevel)-                          showProfDetailLevelFlag)--      ,multiOption "optimization"-         configOptimization (\v flags -> flags { configOptimization = v })-         [optArg' "n" (Flag . flagToOptimisationLevel)-                     (\f -> case f of-                              Flag NoOptimisation      -> []-                              Flag NormalOptimisation  -> [Nothing]-                              Flag MaximumOptimisation -> [Just "2"]-                              _                        -> [])-                 "O" ["enable-optimization","enable-optimisation"]-                 "Build with optimization (n is 0--2, default is 1)",-          noArg (Flag NoOptimisation) []-                ["disable-optimization","disable-optimisation"]-                "Build without optimization"-         ]--      ,multiOption "debug-info"-         configDebugInfo (\v flags -> flags { configDebugInfo = v })-         [optArg' "n" (Flag . flagToDebugInfoLevel)-                     (\f -> case f of-                              Flag NoDebugInfo      -> []-                              Flag MinimalDebugInfo -> [Just "1"]-                              Flag NormalDebugInfo  -> [Nothing]-                              Flag MaximalDebugInfo -> [Just "3"]-                              _                     -> [])-                 "" ["enable-debug-info"]-                 "Emit debug info (n is 0--3, default is 0)",-          noArg (Flag NoDebugInfo) []-                ["disable-debug-info"]-                "Don't emit debug info"-         ]--      ,option "" ["library-for-ghci"]-         "compile library for use with GHCi"-         configGHCiLib (\v flags -> flags { configGHCiLib = v })-         (boolOpt [] [])--      ,option "" ["split-sections"]-         "compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)"-         configSplitSections (\v flags -> flags { configSplitSections = v })-         (boolOpt [] [])--      ,option "" ["split-objs"]-         "split library into smaller objects to reduce binary sizes (GHC 6.6+)"-         configSplitObjs (\v flags -> flags { configSplitObjs = v })-         (boolOpt [] [])--      ,option "" ["executable-stripping"]-         "strip executables upon installation to reduce binary sizes"-         configStripExes (\v flags -> flags { configStripExes = v })-         (boolOpt [] [])--      ,option "" ["library-stripping"]-         "strip libraries upon installation to reduce binary sizes"-         configStripLibs (\v flags -> flags { configStripLibs = v })-         (boolOpt [] [])--      ,option "" ["configure-option"]-         "Extra option for configure"-         configConfigureArgs (\v flags -> flags { configConfigureArgs = v })-         (reqArg' "OPT" (\x -> [x]) id)--      ,option "" ["user-install"]-         "doing a per-user installation"-         configUserInstall (\v flags -> flags { configUserInstall = v })-         (boolOpt' ([],["user"]) ([], ["global"]))--      ,option "" ["package-db"]-         (   "Append the given package database to the list of package"-          ++ " databases used (to satisfy dependencies and register into)."-          ++ " May be a specific file, 'global' or 'user'. The initial list"-          ++ " is ['global'], ['global', 'user'], or ['global', $sandbox],"-          ++ " depending on context. Use 'clear' to reset the list to empty."-          ++ " See the user guide for details.")-         configPackageDBs (\v flags -> flags { configPackageDBs = v })-         (reqArg' "DB" readPackageDbList showPackageDbList)--      ,option "f" ["flags"]-         "Force values for the given flags in Cabal conditionals in the .cabal file.  E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false."-         configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v })-         (reqArg "FLAGS"-              (parsecToReadE (\err -> "Invalid flag assignment: " ++ err) legacyParsecFlagAssignment)-              legacyShowFlagAssignment')--      ,option "" ["extra-include-dirs"]-         "A list of directories to search for header files"-         configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v})-         (reqArg' "PATH" (\x -> [x]) id)--      ,option "" ["deterministic"]-         "Try to be as deterministic as possible (used by the test suite)"-         configDeterministic (\v flags -> flags {configDeterministic = v})-         (boolOpt [] [])--      ,option "" ["ipid"]-         "Installed package ID to compile this package as"-         configIPID (\v flags -> flags {configIPID = v})-         (reqArgFlag "IPID")--      ,option "" ["cid"]-         "Installed component ID to compile this component as"-         (fmap prettyShow . configCID) (\v flags -> flags {configCID = fmap mkComponentId v})-         (reqArgFlag "CID")--      ,option "" ["extra-lib-dirs"]-         "A list of directories to search for external libraries"-         configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v})-         (reqArg' "PATH" (\x -> [x]) id)--      ,option "" ["extra-framework-dirs"]-         "A list of directories to search for external frameworks (OS X only)"-         configExtraFrameworkDirs-         (\v flags -> flags {configExtraFrameworkDirs = v})-         (reqArg' "PATH" (\x -> [x]) id)--      ,option "" ["extra-prog-path"]-         "A list of directories to search for required programs (in addition to the normal search locations)"-         configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v})-         (reqArg' "PATH" (\x -> toNubList [x]) fromNubList)--      ,option "" ["constraint"]-         "A list of additional constraints on the dependencies."-         configConstraints (\v flags -> flags { configConstraints = v})-         (reqArg "DEPENDENCY"-                 (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec))-                 (map prettyShow))--      ,option "" ["dependency"]-         "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\""-         configDependencies (\v flags -> flags { configDependencies = v})-         (reqArg "NAME[:COMPONENT_NAME]=CID"-                 (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent))-                 (map (\(GivenComponent pn cn cid) ->-                     prettyShow pn-                     ++ case cn of LMainLibName -> ""-                                   LSubLibName n -> ":" ++ prettyShow n-                     ++ "=" ++ prettyShow cid)))--      ,option "" ["instantiate-with"]-        "A mapping of signature names to concrete module instantiations."-        configInstantiateWith (\v flags -> flags { configInstantiateWith = v  })-        (reqArg "NAME=MOD"-            (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (:[]) parsecModSubstEntry))-            (map (Disp.renderStyle defaultStyle . dispModSubstEntry)))--      ,option "" ["tests"]-         "dependency checking and compilation for test suites listed in the package description file."-         configTests (\v flags -> flags { configTests = v })-         (boolOpt [] [])--      ,option "" ["coverage"]-         "build package with Haskell Program Coverage. (GHC only)"-         configCoverage (\v flags -> flags { configCoverage = v })-         (boolOpt [] [])--      ,option "" ["library-coverage"]-         "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)"-         configLibCoverage (\v flags -> flags { configLibCoverage = v })-         (boolOpt [] [])--      ,option "" ["exact-configuration"]-         "All direct dependencies and flags are provided on the command line."-         configExactConfiguration-         (\v flags -> flags { configExactConfiguration = v })-         trueArg--      ,option "" ["benchmarks"]-         "dependency checking and compilation for benchmarks listed in the package description file."-         configBenchmarks (\v flags -> flags { configBenchmarks = v })-         (boolOpt [] [])--      ,option "" ["relocatable"]-         "building a package that is relocatable. (GHC only)"-         configRelocatable (\v flags -> flags { configRelocatable = v})-         (boolOpt [] [])--      ,option "" ["response-files"]-         "enable workaround for old versions of programs like \"ar\" that do not support @file arguments"-         configUseResponseFiles-         (\v flags -> flags { configUseResponseFiles = v })-         (boolOpt' ([], ["disable-response-files"]) ([], []))--      ,option "" ["allow-depending-on-private-libs"]-         (  "Allow depending on private libraries. "-         ++ "If set, the library visibility check MUST be done externally." )-         configAllowDependingOnPrivateLibs-         (\v flags -> flags { configAllowDependingOnPrivateLibs = v })-         trueArg-      ]-  where-    liftInstallDirs =-      liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v })--    reqPathTemplateArgFlag title _sf _lf d get set =-      reqArgFlag title _sf _lf d-        (fmap fromPathTemplate . get) (set . fmap toPathTemplate)--readPackageDbList :: String -> [Maybe PackageDB]-readPackageDbList "clear"  = [Nothing]-readPackageDbList "global" = [Just GlobalPackageDB]-readPackageDbList "user"   = [Just UserPackageDB]-readPackageDbList other    = [Just (SpecificPackageDB other)]--showPackageDbList :: [Maybe PackageDB] -> [String]-showPackageDbList = map showPackageDb-  where-    showPackageDb Nothing                       = "clear"-    showPackageDb (Just GlobalPackageDB)        = "global"-    showPackageDb (Just UserPackageDB)          = "user"-    showPackageDb (Just (SpecificPackageDB db)) = db--showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String]-showProfDetailLevelFlag NoFlag    = []-showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl]--parsecGivenComponent :: ParsecParser GivenComponent-parsecGivenComponent = do-  pn <- parsec-  ln <- P.option LMainLibName $ do-    _ <- P.char ':'-    ucn <- parsec-    return $ if unUnqualComponentName ucn == unPackageName pn-             then LMainLibName-             else LSubLibName ucn-  _ <- P.char '='-  cid <- parsec-  return $ GivenComponent pn ln cid--installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))]-installDirsOptions =-  [ option "" ["prefix"]-      "bake this prefix in preparation of installation"-      prefix (\v flags -> flags { prefix = v })-      installDirArg--  , option "" ["bindir"]-      "installation directory for executables"-      bindir (\v flags -> flags { bindir = v })-      installDirArg--  , option "" ["libdir"]-      "installation directory for libraries"-      libdir (\v flags -> flags { libdir = v })-      installDirArg--  , option "" ["libsubdir"]-      "subdirectory of libdir in which libs are installed"-      libsubdir (\v flags -> flags { libsubdir = v })-      installDirArg--  , option "" ["dynlibdir"]-      "installation directory for dynamic libraries"-      dynlibdir (\v flags -> flags { dynlibdir = v })-      installDirArg--  , option "" ["libexecdir"]-      "installation directory for program executables"-      libexecdir (\v flags -> flags { libexecdir = v })-      installDirArg--  , option "" ["libexecsubdir"]-      "subdirectory of libexecdir in which private executables are installed"-      libexecsubdir (\v flags -> flags { libexecsubdir = v })-      installDirArg--  , option "" ["datadir"]-      "installation directory for read-only data"-      datadir (\v flags -> flags { datadir = v })-      installDirArg--  , option "" ["datasubdir"]-      "subdirectory of datadir in which data files are installed"-      datasubdir (\v flags -> flags { datasubdir = v })-      installDirArg--  , option "" ["docdir"]-      "installation directory for documentation"-      docdir (\v flags -> flags { docdir = v })-      installDirArg--  , option "" ["htmldir"]-      "installation directory for HTML documentation"-      htmldir (\v flags -> flags { htmldir = v })-      installDirArg--  , option "" ["haddockdir"]-      "installation directory for haddock interfaces"-      haddockdir (\v flags -> flags { haddockdir = v })-      installDirArg--  , option "" ["sysconfdir"]-      "installation directory for configuration files"-      sysconfdir (\v flags -> flags { sysconfdir = v })-      installDirArg-  ]-  where-    installDirArg _sf _lf d get set =-      reqArgFlag "DIR" _sf _lf d-        (fmap fromPathTemplate . get) (set . fmap toPathTemplate)--emptyConfigFlags :: ConfigFlags-emptyConfigFlags = mempty--instance Monoid ConfigFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup ConfigFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * Copy flags--- ---------------------------------------------------------------- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity)-data CopyFlags = CopyFlags {-    copyDest      :: Flag CopyDest,-    copyDistPref  :: Flag FilePath,-    copyVerbosity :: Flag Verbosity,-    -- This is the same hack as in 'buildArgs'.  But I (ezyang) don't-    -- think it's a hack, it's the right way to make hooks more robust-    -- TODO: Stop using this eventually when 'UserHooks' gets changed-    copyArgs :: [String],-    copyCabalFilePath :: Flag FilePath-  }-  deriving (Show, Generic)--defaultCopyFlags :: CopyFlags-defaultCopyFlags  = CopyFlags {-    copyDest      = Flag NoCopyDest,-    copyDistPref  = NoFlag,-    copyVerbosity = Flag normal,-    copyArgs      = [],-    copyCabalFilePath = mempty-  }--copyCommand :: CommandUI CopyFlags-copyCommand = CommandUI-  { commandName         = "copy"-  , commandSynopsis     = "Copy the files of all/specific components to install locations."-  , commandDescription  = Just $ \_ -> wrapText $-          "Components encompass executables and libraries. "-       ++ "Does not call register, and allows a prefix at install time. "-       ++ "Without the --destdir flag, configure determines location.\n"-  , commandNotes        = Just $ \pname ->-       "Examples:\n"-        ++ "  " ++ pname ++ " copy           "-        ++ "    All the components in the package\n"-        ++ "  " ++ pname ++ " copy foo       "-        ++ "    A component (i.e. lib, exe, test suite)"-  , commandUsage        = usageAlternatives "copy" $-      [ "[FLAGS]"-      , "COMPONENTS [FLAGS]"-      ]-  , commandDefaultFlags = defaultCopyFlags-  , commandOptions      = \showOrParseArgs -> case showOrParseArgs of-      ShowArgs -> filter ((`notElem` ["target-package-db"])-                          . optionName) $ copyOptions ShowArgs-      ParseArgs -> copyOptions ParseArgs-}--copyOptions ::  ShowOrParseArgs -> [OptionField CopyFlags]-copyOptions showOrParseArgs =-  [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v })--  ,optionDistPref-    copyDistPref (\d flags -> flags { copyDistPref = d })-    showOrParseArgs--  ,option "" ["destdir"]-    "directory to copy files to, prepended to installation directories"-    copyDest (\v flags -> case copyDest flags of-                 Flag (CopyToDb _) -> error "Use either 'destdir' or 'target-package-db'."-                 _ -> flags { copyDest = v })-    (reqArg "DIR" (succeedReadE (Flag . CopyTo))-      (\f -> case f of Flag (CopyTo p) -> [p]; _ -> []))--  ,option "" ["target-package-db"]-    "package database to copy files into. Required when using ${pkgroot} prefix."-    copyDest (\v flags -> case copyDest flags of-                 NoFlag -> flags { copyDest = v }-                 Flag NoCopyDest -> flags { copyDest = v }-                 _ -> error "Use either 'destdir' or 'target-package-db'.")-    (reqArg "DATABASE" (succeedReadE (Flag . CopyToDb))-      (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> []))-  ]--emptyCopyFlags :: CopyFlags-emptyCopyFlags = mempty--instance Monoid CopyFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup CopyFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * Install flags--- ---------------------------------------------------------------- | Flags to @install@: (package db, verbosity)-data InstallFlags = InstallFlags {-    installPackageDB :: Flag PackageDB,-    installDest      :: Flag CopyDest,-    installDistPref  :: Flag FilePath,-    installUseWrapper :: Flag Bool,-    installInPlace    :: Flag Bool,-    installVerbosity :: Flag Verbosity,-    -- this is only here, because we can not-    -- change the hooks API.-    installCabalFilePath :: Flag FilePath-  }-  deriving (Show, Generic)--defaultInstallFlags :: InstallFlags-defaultInstallFlags  = InstallFlags {-    installPackageDB = NoFlag,-    installDest      = Flag NoCopyDest,-    installDistPref  = NoFlag,-    installUseWrapper = Flag False,-    installInPlace    = Flag False,-    installVerbosity = Flag normal,-    installCabalFilePath = mempty-  }--installCommand :: CommandUI InstallFlags-installCommand = CommandUI-  { commandName         = "install"-  , commandSynopsis     =-      "Copy the files into the install locations. Run register."-  , commandDescription  = Just $ \_ -> wrapText $-         "Unlike the copy command, install calls the register command."-      ++ "If you want to install into a location that is not what was"-      ++ "specified in the configure step, use the copy command.\n"-  , commandNotes        = Nothing-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " install [FLAGS]\n"-  , commandDefaultFlags = defaultInstallFlags-  , commandOptions      = \showOrParseArgs -> case showOrParseArgs of-      ShowArgs -> filter ((`notElem` ["target-package-db"])-                          . optionName) $ installOptions ShowArgs-      ParseArgs -> installOptions ParseArgs-  }--installOptions ::  ShowOrParseArgs -> [OptionField InstallFlags]-installOptions showOrParseArgs =-  [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v })-  ,optionDistPref-    installDistPref (\d flags -> flags { installDistPref = d })-    showOrParseArgs--  ,option "" ["inplace"]-    "install the package in the install subdirectory of the dist prefix, so it can be used without being installed"-    installInPlace (\v flags -> flags { installInPlace = v })-    trueArg--  ,option "" ["shell-wrappers"]-    "using shell script wrappers around executables"-    installUseWrapper (\v flags -> flags { installUseWrapper = v })-    (boolOpt [] [])--  ,option "" ["package-db"] ""-    installPackageDB (\v flags -> flags { installPackageDB = v })-    (choiceOpt [ (Flag UserPackageDB, ([],["user"]),-                   "upon configuration register this package in the user's local package database")-               , (Flag GlobalPackageDB, ([],["global"]),-                   "(default) upon configuration register this package in the system-wide package database")])-  ,option "" ["target-package-db"]-    "package database to install into. Required when using ${pkgroot} prefix."-    installDest (\v flags -> flags { installDest = v })-    (reqArg "DATABASE" (succeedReadE (Flag . CopyToDb))-      (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> []))-  ]--emptyInstallFlags :: InstallFlags-emptyInstallFlags = mempty--instance Monoid InstallFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup InstallFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * SDist flags--- ---------------------------------------------------------------- | Flags to @sdist@: (snapshot, verbosity)-data SDistFlags = SDistFlags {-    sDistSnapshot    :: Flag Bool,-    sDistDirectory   :: Flag FilePath,-    sDistDistPref    :: Flag FilePath,-    sDistListSources :: Flag FilePath,-    sDistVerbosity   :: Flag Verbosity-  }-  deriving (Show, Generic, Typeable)--defaultSDistFlags :: SDistFlags-defaultSDistFlags = SDistFlags {-    sDistSnapshot    = Flag False,-    sDistDirectory   = mempty,-    sDistDistPref    = NoFlag,-    sDistListSources = mempty,-    sDistVerbosity   = Flag normal-  }--sdistCommand :: CommandUI SDistFlags-sdistCommand = CommandUI-  { commandName         = "sdist"-  , commandSynopsis     =-      "Generate a source distribution file (.tar.gz)."-  , commandDescription  = Nothing-  , commandNotes        = Nothing-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " sdist [FLAGS]\n"-  , commandDefaultFlags = defaultSDistFlags-  , commandOptions      = \showOrParseArgs ->-      [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v })-      ,optionDistPref-         sDistDistPref (\d flags -> flags { sDistDistPref = d })-         showOrParseArgs--      ,option "" ["list-sources"]-         "Just write a list of the package's sources to a file"-         sDistListSources (\v flags -> flags { sDistListSources = v })-         (reqArgFlag "FILE")--      ,option "" ["snapshot"]-         "Produce a snapshot source distribution"-         sDistSnapshot (\v flags -> flags { sDistSnapshot = v })-         trueArg--      ,option "" ["output-directory"]-       ("Generate a source distribution in the given directory, "-        ++ "without creating a tarball")-         sDistDirectory (\v flags -> flags { sDistDirectory = v })-         (reqArgFlag "DIR")-      ]-  }--emptySDistFlags :: SDistFlags-emptySDistFlags = mempty--instance Monoid SDistFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup SDistFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * Register flags--- ---------------------------------------------------------------- | Flags to @register@ and @unregister@: (user package, gen-script,--- in-place, verbosity)-data RegisterFlags = RegisterFlags {-    regPackageDB   :: Flag PackageDB,-    regGenScript   :: Flag Bool,-    regGenPkgConf  :: Flag (Maybe FilePath),-    regInPlace     :: Flag Bool,-    regDistPref    :: Flag FilePath,-    regPrintId     :: Flag Bool,-    regVerbosity   :: Flag Verbosity,-    -- Same as in 'buildArgs' and 'copyArgs'-    regArgs        :: [String],-    regCabalFilePath :: Flag FilePath-  }-  deriving (Show, Generic, Typeable)--defaultRegisterFlags :: RegisterFlags-defaultRegisterFlags = RegisterFlags {-    regPackageDB   = NoFlag,-    regGenScript   = Flag False,-    regGenPkgConf  = NoFlag,-    regInPlace     = Flag False,-    regDistPref    = NoFlag,-    regPrintId     = Flag False,-    regArgs        = [],-    regCabalFilePath = mempty,-    regVerbosity   = Flag normal-  }--registerCommand :: CommandUI RegisterFlags-registerCommand = CommandUI-  { commandName         = "register"-  , commandSynopsis     =-      "Register this package with the compiler."-  , commandDescription  = Nothing-  , commandNotes        = Nothing-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " register [FLAGS]\n"-  , commandDefaultFlags = defaultRegisterFlags-  , commandOptions      = \showOrParseArgs ->-      [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v })-      ,optionDistPref-         regDistPref (\d flags -> flags { regDistPref = d })-         showOrParseArgs--      ,option "" ["packageDB"] ""-         regPackageDB (\v flags -> flags { regPackageDB = v })-         (choiceOpt [ (Flag UserPackageDB, ([],["user"]),-                                "upon registration, register this package in the user's local package database")-                    , (Flag GlobalPackageDB, ([],["global"]),-                                "(default)upon registration, register this package in the system-wide package database")])--      ,option "" ["inplace"]-         "register the package in the build location, so it can be used without being installed"-         regInPlace (\v flags -> flags { regInPlace = v })-         trueArg--      ,option "" ["gen-script"]-         "instead of registering, generate a script to register later"-         regGenScript (\v flags -> flags { regGenScript = v })-         trueArg--      ,option "" ["gen-pkg-config"]-         "instead of registering, generate a package registration file/directory"-         regGenPkgConf (\v flags -> flags { regGenPkgConf  = v })-         (optArg' "PKG" Flag flagToList)--      ,option "" ["print-ipid"]-         "print the installed package ID calculated for this package"-         regPrintId (\v flags -> flags { regPrintId = v })-         trueArg-      ]-  }--unregisterCommand :: CommandUI RegisterFlags-unregisterCommand = CommandUI-  { commandName         = "unregister"-  , commandSynopsis     =-      "Unregister this package with the compiler."-  , commandDescription  = Nothing-  , commandNotes        = Nothing-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " unregister [FLAGS]\n"-  , commandDefaultFlags = defaultRegisterFlags-  , commandOptions      = \showOrParseArgs ->-      [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v })-      ,optionDistPref-         regDistPref (\d flags -> flags { regDistPref = d })-          showOrParseArgs--      ,option "" ["user"] ""-         regPackageDB (\v flags -> flags { regPackageDB = v })-         (choiceOpt [ (Flag UserPackageDB, ([],["user"]),-                              "unregister this package in the user's local package database")-                    , (Flag GlobalPackageDB, ([],["global"]),-                              "(default) unregister this package in the  system-wide package database")])--      ,option "" ["gen-script"]-         "Instead of performing the unregister command, generate a script to unregister later"-         regGenScript (\v flags -> flags { regGenScript = v })-         trueArg-      ]-  }--emptyRegisterFlags :: RegisterFlags-emptyRegisterFlags = mempty--instance Monoid RegisterFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup RegisterFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * HsColour flags--- --------------------------------------------------------------data HscolourFlags = HscolourFlags {-    hscolourCSS         :: Flag FilePath,-    hscolourExecutables :: Flag Bool,-    hscolourTestSuites  :: Flag Bool,-    hscolourBenchmarks  :: Flag Bool,-    hscolourForeignLibs :: Flag Bool,-    hscolourDistPref    :: Flag FilePath,-    hscolourVerbosity   :: Flag Verbosity,-    hscolourCabalFilePath :: Flag FilePath-    }-  deriving (Show, Generic, Typeable)--emptyHscolourFlags :: HscolourFlags-emptyHscolourFlags = mempty--defaultHscolourFlags :: HscolourFlags-defaultHscolourFlags = HscolourFlags {-    hscolourCSS         = NoFlag,-    hscolourExecutables = Flag False,-    hscolourTestSuites  = Flag False,-    hscolourBenchmarks  = Flag False,-    hscolourDistPref    = NoFlag,-    hscolourForeignLibs = Flag False,-    hscolourVerbosity   = Flag normal,-    hscolourCabalFilePath = mempty-  }--instance Monoid HscolourFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup HscolourFlags where-  (<>) = gmappend--hscolourCommand :: CommandUI HscolourFlags-hscolourCommand = CommandUI-  { commandName         = "hscolour"-  , commandSynopsis     =-      "Generate HsColour colourised code, in HTML format."-  , commandDescription  = Just (\_ -> "Requires the hscolour program.\n")-  , commandNotes        = Just $ \_ ->-      "Deprecated in favour of 'cabal haddock --hyperlink-source'."-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " hscolour [FLAGS]\n"-  , commandDefaultFlags = defaultHscolourFlags-  , commandOptions      = \showOrParseArgs ->-      [optionVerbosity hscolourVerbosity-       (\v flags -> flags { hscolourVerbosity = v })-      ,optionDistPref-         hscolourDistPref (\d flags -> flags { hscolourDistPref = d })-         showOrParseArgs--      ,option "" ["executables"]-         "Run hscolour for Executables targets"-         hscolourExecutables (\v flags -> flags { hscolourExecutables = v })-         trueArg--      ,option "" ["tests"]-         "Run hscolour for Test Suite targets"-         hscolourTestSuites (\v flags -> flags { hscolourTestSuites = v })-         trueArg--      ,option "" ["benchmarks"]-         "Run hscolour for Benchmark targets"-         hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v })-         trueArg--      ,option "" ["foreign-libraries"]-         "Run hscolour for Foreign Library targets"-         hscolourForeignLibs (\v flags -> flags { hscolourForeignLibs = v })-         trueArg--      ,option "" ["all"]-         "Run hscolour for all targets"-         (\f -> allFlags [ hscolourExecutables f-                         , hscolourTestSuites  f-                         , hscolourBenchmarks  f-                         , hscolourForeignLibs f-                         ])-         (\v flags -> flags { hscolourExecutables = v-                            , hscolourTestSuites  = v-                            , hscolourBenchmarks  = v-                            , hscolourForeignLibs = v-                            })-         trueArg--      ,option "" ["css"]-         "Use a cascading style sheet"-         hscolourCSS (\v flags -> flags { hscolourCSS = v })-         (reqArgFlag "PATH")-      ]-  }---- --------------------------------------------------------------- * Haddock flags--- ----------------------------------------------------------------- | When we build haddock documentation, there are two cases:------ 1. We build haddocks only for the current development version,---    intended for local use and not for distribution. In this case,---    we store the generated documentation in @<dist>/doc/html/<package name>@.------ 2. We build haddocks for intended for uploading them to hackage.---    In this case, we need to follow the layout that hackage expects---    from documentation tarballs, and we might also want to use different---    flags than for development builds, so in this case we store the generated---    documentation in @<dist>/doc/html/<package id>-docs@.-data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic, Typeable)--instance Binary HaddockTarget-instance Structured HaddockTarget--instance Pretty HaddockTarget where-    pretty ForHackage     = Disp.text "for-hackage"-    pretty ForDevelopment = Disp.text "for-development"--instance Parsec HaddockTarget where-    parsec = P.choice [ P.try $ P.string "for-hackage"     >> return ForHackage-                      , P.string "for-development" >> return ForDevelopment]--data HaddockFlags = HaddockFlags {-    haddockProgramPaths :: [(String, FilePath)],-    haddockProgramArgs  :: [(String, [String])],-    haddockHoogle       :: Flag Bool,-    haddockHtml         :: Flag Bool,-    haddockHtmlLocation :: Flag String,-    haddockForHackage   :: Flag HaddockTarget,-    haddockExecutables  :: Flag Bool,-    haddockTestSuites   :: Flag Bool,-    haddockBenchmarks   :: Flag Bool,-    haddockForeignLibs  :: Flag Bool,-    haddockInternal     :: Flag Bool,-    haddockCss          :: Flag FilePath,-    haddockLinkedSource :: Flag Bool,-    haddockQuickJump    :: Flag Bool,-    haddockHscolourCss  :: Flag FilePath,-    haddockContents     :: Flag PathTemplate,-    haddockDistPref     :: Flag FilePath,-    haddockKeepTempFiles:: Flag Bool,-    haddockVerbosity    :: Flag Verbosity,-    haddockCabalFilePath :: Flag FilePath,-    haddockArgs         :: [String]-  }-  deriving (Show, Generic, Typeable)--defaultHaddockFlags :: HaddockFlags-defaultHaddockFlags  = HaddockFlags {-    haddockProgramPaths = mempty,-    haddockProgramArgs  = [],-    haddockHoogle       = Flag False,-    haddockHtml         = Flag False,-    haddockHtmlLocation = NoFlag,-    haddockForHackage   = NoFlag,-    haddockExecutables  = Flag False,-    haddockTestSuites   = Flag False,-    haddockBenchmarks   = Flag False,-    haddockForeignLibs  = Flag False,-    haddockInternal     = Flag False,-    haddockCss          = NoFlag,-    haddockLinkedSource = Flag False,-    haddockQuickJump    = Flag False,-    haddockHscolourCss  = NoFlag,-    haddockContents     = NoFlag,-    haddockDistPref     = NoFlag,-    haddockKeepTempFiles= Flag False,-    haddockVerbosity    = Flag normal,-    haddockCabalFilePath = mempty,-    haddockArgs         = mempty-  }--haddockCommand :: CommandUI HaddockFlags-haddockCommand = CommandUI-  { commandName         = "haddock"-  , commandSynopsis     = "Generate Haddock HTML documentation."-  , commandDescription  = Just $ \_ ->-      "Requires the program haddock, version 2.x.\n"-  , commandNotes        = Nothing-  , commandUsage        = usageAlternatives "haddock" $-      [ "[FLAGS]"-      , "COMPONENTS [FLAGS]"-      ]-  , commandDefaultFlags = defaultHaddockFlags-  , commandOptions      = \showOrParseArgs ->-         haddockOptions showOrParseArgs-      ++ programDbPaths   progDb ParseArgs-             haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})-      ++ programDbOption  progDb showOrParseArgs-             haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v })-      ++ programDbOptions progDb ParseArgs-             haddockProgramArgs  (\v flags -> flags { haddockProgramArgs = v})-  }-  where-    progDb = addKnownProgram haddockProgram-             $ addKnownProgram ghcProgram-             $ emptyProgramDb--haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags]-haddockOptions showOrParseArgs =-  [optionVerbosity haddockVerbosity-   (\v flags -> flags { haddockVerbosity = v })-  ,optionDistPref-   haddockDistPref (\d flags -> flags { haddockDistPref = d })-   showOrParseArgs--  ,option "" ["keep-temp-files"]-   "Keep temporary files"-   haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b })-   trueArg--  ,option "" ["hoogle"]-   "Generate a hoogle database"-   haddockHoogle (\v flags -> flags { haddockHoogle = v })-   trueArg--  ,option "" ["html"]-   "Generate HTML documentation (the default)"-   haddockHtml (\v flags -> flags { haddockHtml = v })-   trueArg--  ,option "" ["html-location"]-   "Location of HTML documentation for pre-requisite packages"-   haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v })-   (reqArgFlag "URL")--  ,option "" ["for-hackage"]-   "Collection of flags to generate documentation suitable for upload to hackage"-   haddockForHackage (\v flags -> flags { haddockForHackage = v })-   (noArg (Flag ForHackage))--  ,option "" ["executables"]-   "Run haddock for Executables targets"-   haddockExecutables (\v flags -> flags { haddockExecutables = v })-   trueArg--  ,option "" ["tests"]-   "Run haddock for Test Suite targets"-   haddockTestSuites (\v flags -> flags { haddockTestSuites = v })-   trueArg--  ,option "" ["benchmarks"]-   "Run haddock for Benchmark targets"-   haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v })-   trueArg--  ,option "" ["foreign-libraries"]-   "Run haddock for Foreign Library targets"-   haddockForeignLibs (\v flags -> flags { haddockForeignLibs = v })-   trueArg--  ,option "" ["all"]-   "Run haddock for all targets"-   (\f -> allFlags [ haddockExecutables f-                   , haddockTestSuites  f-                   , haddockBenchmarks  f-                   , haddockForeignLibs f-                   ])-         (\v flags -> flags { haddockExecutables = v-                            , haddockTestSuites  = v-                            , haddockBenchmarks  = v-                            , haddockForeignLibs = v-                            })-         trueArg--  ,option "" ["internal"]-   "Run haddock for internal modules and include all symbols"-   haddockInternal (\v flags -> flags { haddockInternal = v })-   trueArg--  ,option "" ["css"]-   "Use PATH as the haddock stylesheet"-   haddockCss (\v flags -> flags { haddockCss = v })-   (reqArgFlag "PATH")--  ,option "" ["hyperlink-source","hyperlink-sources","hyperlinked-source"]-   "Hyperlink the documentation to the source code"-   haddockLinkedSource (\v flags -> flags { haddockLinkedSource = v })-   trueArg--  ,option "" ["quickjump"]-   "Generate an index for interactive documentation navigation"-   haddockQuickJump (\v flags -> flags { haddockQuickJump = v })-   trueArg--  ,option "" ["hscolour-css"]-   "Use PATH as the HsColour stylesheet"-   haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v })-   (reqArgFlag "PATH")--  ,option "" ["contents-location"]-   "Bake URL in as the location for the contents page"-   haddockContents (\v flags -> flags { haddockContents = v })-   (reqArg' "URL"-    (toFlag . toPathTemplate)-    (flagToList . fmap fromPathTemplate))-  ]--emptyHaddockFlags :: HaddockFlags-emptyHaddockFlags = mempty--instance Monoid HaddockFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup HaddockFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * Clean flags--- --------------------------------------------------------------data CleanFlags = CleanFlags {-    cleanSaveConf  :: Flag Bool,-    cleanDistPref  :: Flag FilePath,-    cleanVerbosity :: Flag Verbosity,-    cleanCabalFilePath :: Flag FilePath-  }-  deriving (Show, Generic, Typeable)--defaultCleanFlags :: CleanFlags-defaultCleanFlags  = CleanFlags {-    cleanSaveConf  = Flag False,-    cleanDistPref  = NoFlag,-    cleanVerbosity = Flag normal,-    cleanCabalFilePath = mempty-  }--cleanCommand :: CommandUI CleanFlags-cleanCommand = CommandUI-  { commandName         = "clean"-  , commandSynopsis     = "Clean up after a build."-  , commandDescription  = Just $ \_ ->-      "Removes .hi, .o, preprocessed sources, etc.\n"-  , commandNotes        = Nothing-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " clean [FLAGS]\n"-  , commandDefaultFlags = defaultCleanFlags-  , commandOptions      = \showOrParseArgs ->-      [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v })-      ,optionDistPref-         cleanDistPref (\d flags -> flags { cleanDistPref = d })-         showOrParseArgs--      ,option "s" ["save-configure"]-         "Do not remove the configuration file (dist/setup-config) during cleaning.  Saves need to reconfigure."-         cleanSaveConf (\v flags -> flags { cleanSaveConf = v })-         trueArg-      ]-  }--emptyCleanFlags :: CleanFlags-emptyCleanFlags = mempty--instance Monoid CleanFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup CleanFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * Build flags--- --------------------------------------------------------------data BuildFlags = BuildFlags {-    buildProgramPaths :: [(String, FilePath)],-    buildProgramArgs :: [(String, [String])],-    buildDistPref    :: Flag FilePath,-    buildVerbosity   :: Flag Verbosity,-    buildNumJobs     :: Flag (Maybe Int),-    -- TODO: this one should not be here, it's just that the silly-    -- UserHooks stop us from passing extra info in other ways-    buildArgs :: [String],-    buildCabalFilePath :: Flag FilePath-  }-  deriving (Read, Show, Generic, Typeable)--defaultBuildFlags :: BuildFlags-defaultBuildFlags  = BuildFlags {-    buildProgramPaths = mempty,-    buildProgramArgs = [],-    buildDistPref    = mempty,-    buildVerbosity   = Flag normal,-    buildNumJobs     = mempty,-    buildArgs        = [],-    buildCabalFilePath = mempty-  }--buildCommand :: ProgramDb -> CommandUI BuildFlags-buildCommand progDb = CommandUI-  { commandName         = "build"-  , commandSynopsis     = "Compile all/specific components."-  , commandDescription  = Just $ \_ -> wrapText $-         "Components encompass executables, tests, and benchmarks.\n"-      ++ "\n"-      ++ "Affected by configuration options, see `configure`.\n"-  , commandNotes        = Just $ \pname ->-       "Examples:\n"-        ++ "  " ++ pname ++ " build           "-        ++ "    All the components in the package\n"-        ++ "  " ++ pname ++ " build foo       "-        ++ "    A component (i.e. lib, exe, test suite)\n\n"-        ++ programFlagsDescription progDb---TODO: re-enable once we have support for module/file targets---        ++ "  " ++ pname ++ " build Foo.Bar   "---        ++ "    A module\n"---        ++ "  " ++ pname ++ " build Foo/Bar.hs"---        ++ "    A file\n\n"---        ++ "If a target is ambiguous it can be qualified with the component "---        ++ "name, e.g.\n"---        ++ "  " ++ pname ++ " build foo:Foo.Bar\n"---        ++ "  " ++ pname ++ " build testsuite1:Foo/Bar.hs\n"-  , commandUsage        = usageAlternatives "build" $-      [ "[FLAGS]"-      , "COMPONENTS [FLAGS]"-      ]-  , commandDefaultFlags = defaultBuildFlags-  , commandOptions      = \showOrParseArgs ->-      [ optionVerbosity-        buildVerbosity (\v flags -> flags { buildVerbosity = v })--      , optionDistPref-        buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs-      ]-      ++ buildOptions progDb showOrParseArgs-  }--buildOptions :: ProgramDb -> ShowOrParseArgs-                -> [OptionField BuildFlags]-buildOptions progDb showOrParseArgs =-  [ optionNumJobs-      buildNumJobs (\v flags -> flags { buildNumJobs = v })-  ]--  ++ programDbPaths progDb showOrParseArgs-       buildProgramPaths (\v flags -> flags { buildProgramPaths = v})--  ++ programDbOption progDb showOrParseArgs-       buildProgramArgs (\v fs -> fs { buildProgramArgs = v })--  ++ programDbOptions progDb showOrParseArgs-       buildProgramArgs (\v flags -> flags { buildProgramArgs = v})--emptyBuildFlags :: BuildFlags-emptyBuildFlags = mempty--instance Monoid BuildFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup BuildFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * REPL Flags--- --------------------------------------------------------------data ReplFlags = ReplFlags {-    replProgramPaths :: [(String, FilePath)],-    replProgramArgs :: [(String, [String])],-    replDistPref    :: Flag FilePath,-    replVerbosity   :: Flag Verbosity,-    replReload      :: Flag Bool,-    replReplOptions :: [String]-  }-  deriving (Show, Generic, Typeable)--defaultReplFlags :: ReplFlags-defaultReplFlags  = ReplFlags {-    replProgramPaths = mempty,-    replProgramArgs = [],-    replDistPref    = NoFlag,-    replVerbosity   = Flag normal,-    replReload      = Flag False,-    replReplOptions = []-  }--instance Monoid ReplFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup ReplFlags where-  (<>) = gmappend--replCommand :: ProgramDb -> CommandUI ReplFlags-replCommand progDb = CommandUI-  { commandName         = "repl"-  , commandSynopsis     =-      "Open an interpreter session for the given component."-  , commandDescription  = Just $ \pname -> wrapText $-         "If the current directory contains no package, ignores COMPONENT "-      ++ "parameters and opens an interactive interpreter session; if a "-      ++ "sandbox is present, its package database will be used.\n"-      ++ "\n"-      ++ "Otherwise, (re)configures with the given or default flags, and "-      ++ "loads the interpreter with the relevant modules. For executables, "-      ++ "tests and benchmarks, loads the main module (and its "-      ++ "dependencies); for libraries all exposed/other modules.\n"-      ++ "\n"-      ++ "The default component is the library itself, or the executable "-      ++ "if that is the only component.\n"-      ++ "\n"-      ++ "Support for loading specific modules is planned but not "-      ++ "implemented yet. For certain scenarios, `" ++ pname-      ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will "-      ++ "not (re)configure and you will have to specify the location of "-      ++ "other modules, if required.\n"--  , commandNotes        = Just $ \pname ->-         "Examples:\n"-      ++ "  " ++ pname ++ " repl           "-      ++ "    The first component in the package\n"-      ++ "  " ++ pname ++ " repl foo       "-      ++ "    A named component (i.e. lib, exe, test suite)\n"-      ++ "  " ++ pname ++ " repl --repl-options=\"-lstdc++\""-      ++ "  Specifying flags for interpreter\n"---TODO: re-enable once we have support for module/file targets---        ++ "  " ++ pname ++ " repl Foo.Bar   "---        ++ "    A module\n"---        ++ "  " ++ pname ++ " repl Foo/Bar.hs"---        ++ "    A file\n\n"---        ++ "If a target is ambiguous it can be qualified with the component "---        ++ "name, e.g.\n"---        ++ "  " ++ pname ++ " repl foo:Foo.Bar\n"---        ++ "  " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n"-  , commandUsage =  \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n"-  , commandDefaultFlags = defaultReplFlags-  , commandOptions = \showOrParseArgs ->-      optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v })-      : optionDistPref-          replDistPref (\d flags -> flags { replDistPref = d })-          showOrParseArgs--      : programDbPaths   progDb showOrParseArgs-          replProgramPaths (\v flags -> flags { replProgramPaths = v})--     ++ programDbOption progDb showOrParseArgs-          replProgramArgs (\v flags -> flags { replProgramArgs = v})--     ++ programDbOptions progDb showOrParseArgs-          replProgramArgs (\v flags -> flags { replProgramArgs = v})--     ++ case showOrParseArgs of-          ParseArgs ->-            [ option "" ["reload"]-              "Used from within an interpreter to update files."-              replReload (\v flags -> flags { replReload = v })-              trueArg-            ]-          _ -> []-     ++ map liftReplOption (replOptions showOrParseArgs)-  }-  where-    liftReplOption = liftOption replReplOptions (\v flags -> flags { replReplOptions = v })--replOptions :: ShowOrParseArgs -> [OptionField [String]]-replOptions _ = [ option [] ["repl-options"] "use this option for the repl" id-              const (reqArg "FLAG" (succeedReadE (:[])) id) ]---- --------------------------------------------------------------- * Test flags--- --------------------------------------------------------------data TestShowDetails = Never | Failures | Always | Streaming | Direct-    deriving (Eq, Ord, Enum, Bounded, Generic, Show, Typeable)--instance Binary TestShowDetails-instance Structured TestShowDetails--knownTestShowDetails :: [TestShowDetails]-knownTestShowDetails = [minBound..maxBound]--instance Pretty TestShowDetails where-    pretty  = Disp.text . lowercase . show--instance Parsec TestShowDetails where-    parsec = maybe (fail "invalid TestShowDetails") return . classify =<< ident-      where-        ident        = P.munch1 (\c -> isAlpha c || c == '_' || c == '-')-        classify str = lookup (lowercase str) enumMap-        enumMap     :: [(String, TestShowDetails)]-        enumMap      = [ (prettyShow x, x)-                       | x <- knownTestShowDetails ]----TODO: do we need this instance?-instance Monoid TestShowDetails where-    mempty = Never-    mappend = (<>)--instance Semigroup TestShowDetails where-    a <> b = if a < b then b else a--data TestFlags = TestFlags {-    testDistPref    :: Flag FilePath,-    testVerbosity   :: Flag Verbosity,-    testHumanLog    :: Flag PathTemplate,-    testMachineLog  :: Flag PathTemplate,-    testShowDetails :: Flag TestShowDetails,-    testKeepTix     :: Flag Bool,-    testWrapper     :: Flag FilePath,-    testFailWhenNoTestSuites :: Flag Bool,-    -- TODO: think about if/how options are passed to test exes-    testOptions     :: [PathTemplate]-  } deriving (Show, Generic, Typeable)--defaultTestFlags :: TestFlags-defaultTestFlags  = TestFlags {-    testDistPref    = NoFlag,-    testVerbosity   = Flag normal,-    testHumanLog    = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log",-    testMachineLog  = toFlag $ toPathTemplate $ "$pkgid.log",-    testShowDetails = toFlag Failures,-    testKeepTix     = toFlag False,-    testWrapper     = NoFlag,-    testFailWhenNoTestSuites = toFlag False,-    testOptions     = []-  }--testCommand :: CommandUI TestFlags-testCommand = CommandUI-  { commandName         = "test"-  , commandSynopsis     =-      "Run all/specific tests in the test suite."-  , commandDescription  = Just $ \pname -> wrapText $-         "If necessary (re)configures with `--enable-tests` flag and builds"-      ++ " the test suite.\n"-      ++ "\n"-      ++ "Remember that the tests' dependencies must be installed if there"-      ++ " are additional ones; e.g. with `" ++ pname-      ++ " install --only-dependencies --enable-tests`.\n"-      ++ "\n"-      ++ "By defining UserHooks in a custom Setup.hs, the package can"-      ++ " define actions to be executed before and after running tests.\n"-  , commandNotes        = Nothing-  , commandUsage        = usageAlternatives "test"-      [ "[FLAGS]"-      , "TESTCOMPONENTS [FLAGS]"-      ]-  , commandDefaultFlags = defaultTestFlags-  , commandOptions = testOptions'-  }--testOptions' ::  ShowOrParseArgs -> [OptionField TestFlags]-testOptions' showOrParseArgs =-  [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v })-  , optionDistPref-        testDistPref (\d flags -> flags { testDistPref = d })-        showOrParseArgs-  , option [] ["log"]-        ("Log all test suite results to file (name template can use "-        ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)")-        testHumanLog (\v flags -> flags { testHumanLog = v })-        (reqArg' "TEMPLATE"-            (toFlag . toPathTemplate)-            (flagToList . fmap fromPathTemplate))-  , option [] ["machine-log"]-        ("Produce a machine-readable log file (name template can use "-        ++ "$pkgid, $compiler, $os, $arch, $result)")-        testMachineLog (\v flags -> flags { testMachineLog = v })-        (reqArg' "TEMPLATE"-            (toFlag . toPathTemplate)-            (flagToList . fmap fromPathTemplate))-  , option [] ["show-details"]-        ("'always': always show results of individual test cases. "-         ++ "'never': never show results of individual test cases. "-         ++ "'failures': show results of failing test cases. "-         ++ "'streaming': show results of test cases in real time."-         ++ "'direct': send results of test cases in real time; no log file.")-        testShowDetails (\v flags -> flags { testShowDetails = v })-        (reqArg "FILTER"-            (parsecToReadE (\_ -> "--show-details flag expects one of "-                          ++ intercalate ", "-                               (map prettyShow knownTestShowDetails))-                        (fmap toFlag parsec))-            (flagToList . fmap prettyShow))-  , option [] ["keep-tix-files"]-        "keep .tix files for HPC between test runs"-        testKeepTix (\v flags -> flags { testKeepTix = v})-        trueArg-  , option [] ["test-wrapper"]-        "Run test through a wrapper."-        testWrapper (\v flags -> flags { testWrapper = v })-        (reqArg' "FILE" (toFlag :: FilePath -> Flag FilePath)-            (flagToList :: Flag FilePath -> [FilePath]))-  , option [] ["fail-when-no-test-suites"]-        ("Exit with failure when no test suites are found.")-        testFailWhenNoTestSuites (\v flags -> flags { testFailWhenNoTestSuites = v})-        trueArg-  , option [] ["test-options"]-        ("give extra options to test executables "-         ++ "(name templates can use $pkgid, $compiler, "-         ++ "$os, $arch, $test-suite)")-        testOptions (\v flags -> flags { testOptions = v })-        (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs)-            (const []))-  , option [] ["test-option"]-        ("give extra option to test executables "-         ++ "(no need to quote options containing spaces, "-         ++ "name template can use $pkgid, $compiler, "-         ++ "$os, $arch, $test-suite)")-        testOptions (\v flags -> flags { testOptions = v })-        (reqArg' "TEMPLATE" (\x -> [toPathTemplate x])-            (map fromPathTemplate))-  ]--emptyTestFlags :: TestFlags-emptyTestFlags  = mempty--instance Monoid TestFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup TestFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * Benchmark flags--- --------------------------------------------------------------data BenchmarkFlags = BenchmarkFlags {-    benchmarkDistPref  :: Flag FilePath,-    benchmarkVerbosity :: Flag Verbosity,-    benchmarkOptions   :: [PathTemplate]-  } deriving (Show, Generic, Typeable)--defaultBenchmarkFlags :: BenchmarkFlags-defaultBenchmarkFlags  = BenchmarkFlags {-    benchmarkDistPref  = NoFlag,-    benchmarkVerbosity = Flag normal,-    benchmarkOptions   = []-  }--benchmarkCommand :: CommandUI BenchmarkFlags-benchmarkCommand = CommandUI-  { commandName         = "bench"-  , commandSynopsis     =-      "Run all/specific benchmarks."-  , commandDescription  = Just $ \pname -> wrapText $-         "If necessary (re)configures with `--enable-benchmarks` flag and"-      ++ " builds the benchmarks.\n"-      ++ "\n"-      ++ "Remember that the benchmarks' dependencies must be installed if"-      ++ " there are additional ones; e.g. with `" ++ pname-      ++ " install --only-dependencies --enable-benchmarks`.\n"-      ++ "\n"-      ++ "By defining UserHooks in a custom Setup.hs, the package can"-      ++ " define actions to be executed before and after running"-      ++ " benchmarks.\n"-  , commandNotes        = Nothing-  , commandUsage        = usageAlternatives "bench"-      [ "[FLAGS]"-      , "BENCHCOMPONENTS [FLAGS]"-      ]-  , commandDefaultFlags = defaultBenchmarkFlags-  , commandOptions = benchmarkOptions'-  }--benchmarkOptions' :: ShowOrParseArgs -> [OptionField BenchmarkFlags]-benchmarkOptions' showOrParseArgs =-  [ optionVerbosity benchmarkVerbosity-    (\v flags -> flags { benchmarkVerbosity = v })-  , optionDistPref-        benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d })-        showOrParseArgs-  , option [] ["benchmark-options"]-        ("give extra options to benchmark executables "-         ++ "(name templates can use $pkgid, $compiler, "-         ++ "$os, $arch, $benchmark)")-        benchmarkOptions (\v flags -> flags { benchmarkOptions = v })-        (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs)-            (const []))-  , option [] ["benchmark-option"]-        ("give extra option to benchmark executables "-         ++ "(no need to quote options containing spaces, "-         ++ "name template can use $pkgid, $compiler, "-         ++ "$os, $arch, $benchmark)")-        benchmarkOptions (\v flags -> flags { benchmarkOptions = v })-        (reqArg' "TEMPLATE" (\x -> [toPathTemplate x])-            (map fromPathTemplate))-  ]--emptyBenchmarkFlags :: BenchmarkFlags-emptyBenchmarkFlags = mempty--instance Monoid BenchmarkFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup BenchmarkFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * Shared options utils--- --------------------------------------------------------------programFlagsDescription :: ProgramDb -> String-programFlagsDescription progDb =-     "The flags --with-PROG and --PROG-option(s) can be used with"-  ++ " the following programs:"-  ++ (concatMap (\line -> "\n  " ++ unwords line) . wrapLine 77 . sort)-     [ programName prog | (prog, _) <- knownPrograms progDb ]-  ++ "\n"---- | For each known program @PROG@ in 'progDb', produce a @with-PROG@--- 'OptionField'.-programDbPaths-  :: ProgramDb-  -> ShowOrParseArgs-  -> (flags -> [(String, FilePath)])-  -> ([(String, FilePath)] -> (flags -> flags))-  -> [OptionField flags]-programDbPaths progDb showOrParseArgs get set =-  programDbPaths' ("with-" ++) progDb showOrParseArgs get set---- | Like 'programDbPaths', but allows to customise the option name.-programDbPaths'-  :: (String -> String)-  -> ProgramDb-  -> ShowOrParseArgs-  -> (flags -> [(String, FilePath)])-  -> ([(String, FilePath)] -> (flags -> flags))-  -> [OptionField flags]-programDbPaths' mkName progDb showOrParseArgs get set =-  case showOrParseArgs of-    -- we don't want a verbose help text list so we just show a generic one:-    ShowArgs  -> [withProgramPath "PROG"]-    ParseArgs -> map (withProgramPath . programName . fst)-                 (knownPrograms progDb)-  where-    withProgramPath prog =-      option "" [mkName prog]-        ("give the path to " ++ prog)-        get set-        (reqArg' "PATH" (\path -> [(prog, path)])-          (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ]))---- | For each known program @PROG@ in 'progDb', produce a @PROG-option@--- 'OptionField'.-programDbOption-  :: ProgramDb-  -> ShowOrParseArgs-  -> (flags -> [(String, [String])])-  -> ([(String, [String])] -> (flags -> flags))-  -> [OptionField flags]-programDbOption progDb showOrParseArgs get set =-  case showOrParseArgs of-    -- we don't want a verbose help text list so we just show a generic one:-    ShowArgs  -> [programOption "PROG"]-    ParseArgs -> map (programOption  . programName . fst)-                 (knownPrograms progDb)-  where-    programOption prog =-      option "" [prog ++ "-option"]-        ("give an extra option to " ++ prog ++-         " (no need to quote options containing spaces)")-        get set-        (reqArg' "OPT" (\arg -> [(prog, [arg])])-           (\progArgs -> concat [ args-                                | (prog', args) <- progArgs, prog==prog' ]))----- | For each known program @PROG@ in 'progDb', produce a @PROG-options@--- 'OptionField'.-programDbOptions-  :: ProgramDb-  -> ShowOrParseArgs-  -> (flags -> [(String, [String])])-  -> ([(String, [String])] -> (flags -> flags))-  -> [OptionField flags]-programDbOptions progDb showOrParseArgs get set =-  case showOrParseArgs of-    -- we don't want a verbose help text list so we just show a generic one:-    ShowArgs  -> [programOptions  "PROG"]-    ParseArgs -> map (programOptions . programName . fst)-                 (knownPrograms progDb)-  where-    programOptions prog =-      option "" [prog ++ "-options"]-        ("give extra options to " ++ prog)-        get set-        (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))---- --------------------------------------------------------------- * GetOpt Utils--- --------------------------------------------------------------boolOpt :: SFlags -> SFlags-           -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a-boolOpt  = Command.boolOpt  flagToMaybe Flag--boolOpt' :: OptFlags -> OptFlags-            -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a-boolOpt' = Command.boolOpt' flagToMaybe Flag--trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a-trueArg  sfT lfT = boolOpt' (sfT, lfT) ([], [])   sfT lfT-falseArg sfF lfF = boolOpt' ([],  [])  (sfF, lfF) sfF lfF--reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->-              (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b-reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList--optionDistPref :: (flags -> Flag FilePath)-               -> (Flag FilePath -> flags -> flags)-               -> ShowOrParseArgs-               -> OptionField flags-optionDistPref get set = \showOrParseArgs ->-  option "" (distPrefFlagName showOrParseArgs)-    (   "The directory where Cabal puts generated build files "-     ++ "(default " ++ defaultDistPref ++ ")")-    get set-    (reqArgFlag "DIR")-  where-    distPrefFlagName ShowArgs  = ["builddir"]-    distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"]--optionVerbosity :: (flags -> Flag Verbosity)-                -> (Flag Verbosity -> flags -> flags)-                -> OptionField flags-optionVerbosity get set =-  option "v" ["verbose"]-    "Control verbosity (n is 0--3, default verbosity level is 1)"-    get set-    (optArg "n" (fmap Flag flagToVerbosity)-                (Flag verbose) -- default Value if no n is given-                (fmap (Just . showForCabal) . flagToList))--optionNumJobs :: (flags -> Flag (Maybe Int))-              -> (Flag (Maybe Int) -> flags -> flags)-              -> OptionField flags-optionNumJobs get set =-  option "j" ["jobs"]-    "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."-    get set-    (optArg "NUM" (fmap Flag numJobsParser)-                  (Flag Nothing)-                  (map (Just . maybe "$ncpus" show) . flagToList))-  where-    numJobsParser :: ReadE (Maybe Int)-    numJobsParser = ReadE $ \s ->-      case s of-        "$ncpus" -> Right Nothing-        _        -> case reads s of-          [(n, "")]-            | n < 1     -> Left "The number of jobs should be 1 or more."-            | otherwise -> Right (Just n)-          _             -> Left "The jobs value should be a number or '$ncpus'"----- --------------------------------------------------------------- * show-build-info command flags--- --------------------------------------------------------------data ShowBuildInfoFlags = ShowBuildInfoFlags-  { buildInfoBuildFlags :: BuildFlags-  , buildInfoOutputFile :: Maybe FilePath-  } deriving (Show, Typeable)--defaultShowBuildFlags  :: ShowBuildInfoFlags-defaultShowBuildFlags =-    ShowBuildInfoFlags-      { buildInfoBuildFlags = defaultBuildFlags-      , buildInfoOutputFile = Nothing-      }--showBuildInfoCommand :: ProgramDb -> CommandUI ShowBuildInfoFlags-showBuildInfoCommand progDb = CommandUI-  { commandName         = "show-build-info"-  , commandSynopsis     = "Emit details about how a package would be built."-  , commandDescription  = Just $ \_ -> wrapText $-         "Components encompass executables, tests, and benchmarks.\n"-      ++ "\n"-      ++ "Affected by configuration options, see `configure`.\n"-  , commandNotes        = Just $ \pname ->-       "Examples:\n"-        ++ "  " ++ pname ++ " show-build-info      "-        ++ "    All the components in the package\n"-        ++ "  " ++ pname ++ " show-build-info foo       "-        ++ "    A component (i.e. lib, exe, test suite)\n\n"-        ++ programFlagsDescription progDb---TODO: re-enable once we have support for module/file targets---        ++ "  " ++ pname ++ " show-build-info Foo.Bar   "---        ++ "    A module\n"---        ++ "  " ++ pname ++ " show-build-info Foo/Bar.hs"---        ++ "    A file\n\n"---        ++ "If a target is ambiguous it can be qualified with the component "---        ++ "name, e.g.\n"---        ++ "  " ++ pname ++ " show-build-info foo:Foo.Bar\n"---        ++ "  " ++ pname ++ " show-build-info testsuite1:Foo/Bar.hs\n"-  , commandUsage        = usageAlternatives "show-build-info" $-      [ "[FLAGS]"-      , "COMPONENTS [FLAGS]"-      ]-  , commandDefaultFlags = defaultShowBuildFlags-  , commandOptions      = \showOrParseArgs ->-      parseBuildFlagsForShowBuildInfoFlags showOrParseArgs progDb-      ++-      [ option [] ["buildinfo-json-output"]-                "Write the result to the given file instead of stdout"-                buildInfoOutputFile (\pf flags -> flags { buildInfoOutputFile = pf })-                (reqArg' "FILE" Just (maybe [] pure))-      ]--  }--parseBuildFlagsForShowBuildInfoFlags :: ShowOrParseArgs -> ProgramDb -> [OptionField ShowBuildInfoFlags]-parseBuildFlagsForShowBuildInfoFlags showOrParseArgs progDb =-  map-      (liftOption-        buildInfoBuildFlags-          (\bf flags -> flags { buildInfoBuildFlags = bf } )-      )-      buildFlags-  where-    buildFlags = buildOptions progDb showOrParseArgs-      ++-      [ optionVerbosity-        buildVerbosity (\v flags -> flags { buildVerbosity = v })--      , optionDistPref-        buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs-      ]---- --------------------------------------------------------------- * Other Utils--- ---------------------------------------------------------------- | Arguments to pass to a @configure@ script, e.g. generated by--- @autoconf@.-configureArgs :: Bool -> ConfigFlags -> [String]-configureArgs bcHack flags-  = hc_flag- ++ optFlag  "with-hc-pkg" configHcPkg- ++ optFlag' "prefix"      prefix- ++ optFlag' "bindir"      bindir- ++ optFlag' "libdir"      libdir- ++ optFlag' "libexecdir"  libexecdir- ++ optFlag' "datadir"     datadir- ++ optFlag' "sysconfdir"  sysconfdir- ++ configConfigureArgs flags-  where-        hc_flag = case (configHcFlavor flags, configHcPath flags) of-                        (_, Flag hc_path) -> [hc_flag_name ++ hc_path]-                        (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc]-                        (NoFlag,NoFlag)   -> []-        hc_flag_name-            --TODO kill off thic bc hack when defaultUserHooks is removed.-            | bcHack    = "--with-hc="-            | otherwise = "--with-compiler="-        optFlag name config_field = case config_field flags of-                        Flag p -> ["--" ++ name ++ "=" ++ p]-                        NoFlag -> []-        optFlag' name config_field = optFlag name (fmap fromPathTemplate-                                                 . config_field-                                                 . configInstallDirs)--configureCCompiler :: Verbosity -> ProgramDb-                      -> IO (FilePath, [String])-configureCCompiler verbosity progdb = configureProg verbosity progdb gccProgram--configureLinker :: Verbosity -> ProgramDb -> IO (FilePath, [String])-configureLinker verbosity progdb = configureProg verbosity progdb ldProgram--configureProg :: Verbosity -> ProgramDb -> Program-                 -> IO (FilePath, [String])-configureProg verbosity programDb prog = do-    (p, _) <- requireProgram verbosity prog programDb-    let pInv = programInvocation p []-    return (progInvokePath pInv, progInvokeArgs pInv)---- | Helper function to split a string into a list of arguments.--- It's supposed to handle quoted things sensibly, eg:------ > splitArgs "--foo=\"C:/Program Files/Bar/" --baz"--- >   = ["--foo=C:/Program Files/Bar", "--baz"]------ > splitArgs "\"-DMSGSTR=\\\"foo bar\\\"\" --baz"--- >   = ["-DMSGSTR=\"foo bar\"","--baz"]----splitArgs :: String -> [String]-splitArgs  = space []-  where-    space :: String -> String -> [String]-    space w []      = word w []-    space w ( c :s)-        | isSpace c = word w (space [] s)-    space w ('"':s) = string w s-    space w s       = nonstring w s--    string :: String -> String -> [String]-    string w []      = word w []-    string w ('"':s) = space w s-    string w ('\\':'"':s) = string ('"':w) s-    string w ( c :s) = string (c:w) s--    nonstring :: String -> String -> [String]-    nonstring w  []      = word w []-    nonstring w  ('"':s) = string w s-    nonstring w  ( c :s) = space (c:w) s--    word [] s = s-    word w  s = reverse w : s---- The test cases kinda have to be rewritten from the ground up... :/---hunitTests :: [Test]---hunitTests =---    let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)]---        (flags, commands', unkFlags, ers)---               = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"]---       in  [TestLabel "very basic option parsing" $ TestList [---                 "getOpt flags" ~: "failed" ~:---                 [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag,---                  WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag]---                 ~=? flags,---                 "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands',---                 "getOpt unknown opts" ~: "failed" ~:---                      ["--unknown1", "--unknown2"] ~=? unkFlags,---                 "getOpt errors" ~: "failed" ~: [] ~=? ers],------               TestLabel "test location of various compilers" $ TestList---               ["configure parsing for prefix and compiler flag" ~: "failed" ~:---                    (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), []))---                   ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"])---                   | (name, comp) <- m],------               TestLabel "find the package tool" $ TestList---               ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~:---                    (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), []))---                   ~=? (parseArgs ["--prefix=/usr/local", "--"++name,---                                   "--with-compiler=/foo/comp", "configure"])---                   | (name, comp) <- m],------               TestLabel "simpler commands" $ TestList---               [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag])---                   | (flag, flagCmd) <- [("build", BuildCmd),---                                         ("install", InstallCmd Nothing False),---                                         ("sdist", SDistCmd),---                                         ("register", RegisterCmd False)]---                  ]---               ]--{- Testing ideas:-   * IO to look for hugs and hugs-pkg (which hugs, etc)-   * quickCheck to test permutations of arguments-   * what other options can we over-ride with a command-line flag?--}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module      :  Distribution.Simple.Setup+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module defines the command line interface for all the Cabal+-- commands. For each command (like @configure@, @build@ etc) it defines a type+-- that holds all the flags, the default set of flags and a 'CommandUI' that+-- maps command line flags to and from the corresponding flags type.+--+-- All the flags types are instances of 'Monoid', see+-- <http://www.haskell.org/pipermail/cabal-devel/2007-December/001509.html>+-- for an explanation.+--+-- The types defined here get used in the front end and especially in+-- @cabal-install@ which has to do quite a bit of manipulating sets of command+-- line flags.+--+-- This is actually relatively nice, it works quite well. The main change it+-- needs is to unify it with the code for managing sets of fields that can be+-- read and written from files. This would allow us to save configure flags in+-- config files.+module Distribution.Simple.Setup+  ( GlobalFlags (..)+  , emptyGlobalFlags+  , defaultGlobalFlags+  , globalCommand+  , CommonSetupFlags (..)+  , defaultCommonSetupFlags+  , commonSetupTempFileOptions+  , ConfigFlags (..)+  , emptyConfigFlags+  , defaultConfigFlags+  , configureCommand+  , configPrograms+  , readPackageDb+  , readPackageDbList+  , showPackageDb+  , showPackageDbList+  , CopyFlags (..)+  , emptyCopyFlags+  , defaultCopyFlags+  , copyCommand+  , InstallFlags (..)+  , emptyInstallFlags+  , defaultInstallFlags+  , installCommand+  , HaddockTarget (..)+  , HaddockFlags (..)+  , emptyHaddockFlags+  , defaultHaddockFlags+  , haddockCommand+  , Visibility (..)+  , HaddockProjectFlags (..)+  , emptyHaddockProjectFlags+  , defaultHaddockProjectFlags+  , haddockProjectCommand+  , HscolourFlags (..)+  , emptyHscolourFlags+  , defaultHscolourFlags+  , hscolourCommand+  , BuildFlags (..)+  , emptyBuildFlags+  , defaultBuildFlags+  , buildCommand+  , DumpBuildInfo (..)+  , ReplFlags (..)+  , defaultReplFlags+  , replCommand+  , ReplOptions (..)+  , CleanFlags (..)+  , emptyCleanFlags+  , defaultCleanFlags+  , cleanCommand+  , RegisterFlags (..)+  , emptyRegisterFlags+  , defaultRegisterFlags+  , registerCommand+  , unregisterCommand+  , SDistFlags (..)+  , emptySDistFlags+  , defaultSDistFlags+  , sdistCommand+  , TestFlags (..)+  , emptyTestFlags+  , defaultTestFlags+  , testCommand+  , TestShowDetails (..)+  , BenchmarkFlags (..)+  , emptyBenchmarkFlags+  , defaultBenchmarkFlags+  , benchmarkCommand+  , CopyDest (..)+  , configureArgs+  , configureOptions+  , configureCCompiler+  , configureLinker+  , buildOptions+  , haddockOptions+  , haddockProjectOptions+  , installDirsOptions+  , testOptions'+  , benchmarkOptions'+  , programDbOptions+  , programDbPaths'+  , programFlagsDescription+  , replOptions+  , splitArgs+  , defaultDistPref+  , optionDistPref+  , Flag+  , pattern Flag+  , pattern NoFlag+  , toFlag+  , fromFlag+  , fromFlagOrDefault+  , flagToMaybe+  , flagToList+  , maybeToFlag+  , BooleanFlag (..)+  , boolOpt+  , boolOpt'+  , trueArg+  , falseArg+  , optionVerbosity+  , BuildingWhat (..)+  , buildingWhatCommonFlags+  , buildingWhatVerbosity+  , buildingWhatWorkingDir+  , buildingWhatDistPref+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Simple.Flag+import Distribution.Simple.InstallDirs+import Distribution.Types.DumpBuildInfo++import Distribution.Simple.Setup.Benchmark+import Distribution.Simple.Setup.Build+import Distribution.Simple.Setup.Clean+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Config+import Distribution.Simple.Setup.Copy+import Distribution.Simple.Setup.Global+import Distribution.Simple.Setup.Haddock+import Distribution.Simple.Setup.Hscolour+import Distribution.Simple.Setup.Install+import Distribution.Simple.Setup.Register+  ( RegisterFlags (..)+  , defaultRegisterFlags+  , emptyRegisterFlags+  , registerCommand+  , unregisterCommand+  )+import Distribution.Simple.Setup.Repl+import Distribution.Simple.Setup.SDist+import Distribution.Simple.Setup.Test+import Distribution.Utils.Path++import Distribution.Verbosity (Verbosity)++-- | What kind of build phase are we doing/hooking into?+--+-- Is this a normal build, or is it perhaps for running an interactive+-- session or Haddock?+data BuildingWhat+  = -- | A normal build.+    BuildNormal BuildFlags+  | -- | Build steps for an interactive session.+    BuildRepl ReplFlags+  | -- | Build steps for generating documentation.+    BuildHaddock HaddockFlags+  | -- | Build steps for Hscolour.+    BuildHscolour HscolourFlags+  deriving (Generic, Show)++buildingWhatCommonFlags :: BuildingWhat -> CommonSetupFlags+buildingWhatCommonFlags = \case+  BuildNormal flags -> buildCommonFlags flags+  BuildRepl flags -> replCommonFlags flags+  BuildHaddock flags -> haddockCommonFlags flags+  BuildHscolour flags -> hscolourCommonFlags flags++buildingWhatVerbosity :: BuildingWhat -> Verbosity+buildingWhatVerbosity = fromFlag . setupVerbosity . buildingWhatCommonFlags++buildingWhatWorkingDir :: BuildingWhat -> Maybe (SymbolicPath CWD (Dir Pkg))+buildingWhatWorkingDir = flagToMaybe . setupWorkingDir . buildingWhatCommonFlags++buildingWhatDistPref :: BuildingWhat -> SymbolicPath Pkg (Dir Dist)+buildingWhatDistPref = fromFlag . setupDistPref . buildingWhatCommonFlags++-- The test cases kinda have to be rewritten from the ground up... :/+-- hunitTests :: [Test]+-- hunitTests =+--    let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)]+--        (flags, commands', unkFlags, ers)+--               = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"]+--       in  [TestLabel "very basic option parsing" $ TestList [+--                 "getOpt flags" ~: "failed" ~:+--                 [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag,+--                  WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag]+--                 ~=? flags,+--                 "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands',+--                 "getOpt unknown opts" ~: "failed" ~:+--                      ["--unknown1", "--unknown2"] ~=? unkFlags,+--                 "getOpt errors" ~: "failed" ~: [] ~=? ers],+--+--               TestLabel "test location of various compilers" $ TestList+--               ["configure parsing for prefix and compiler flag" ~: "failed" ~:+--                    (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), []))+--                   ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"])+--                   | (name, comp) <- m],+--+--               TestLabel "find the package tool" $ TestList+--               ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~:+--                    (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), []))+--                   ~=? (parseArgs ["--prefix=/usr/local", "--"++name,+--                                   "--with-compiler=/foo/comp", "configure"])+--                   | (name, comp) <- m],+--+--               TestLabel "simpler commands" $ TestList+--               [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag])+--                   | (flag, flagCmd) <- [("build", BuildCmd),+--                                         ("install", InstallCmd Nothing False),+--                                         ("sdist", SDistCmd),+--                                         ("register", RegisterCmd False)]+--                  ]+--               ]++{- Testing ideas:+   * IO to look for hugs and hugs-pkg (which hugs, etc)+   * quickCheck to test permutations of arguments+   * what other options can we over-ride with a command-line flag?+-}++instance Binary BuildingWhat+instance Structured BuildingWhat
+ src/Distribution/Simple/Setup/Benchmark.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :  Distribution.Simple.Benchmark+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Definition of the benchmarking command-line options.+-- See: @Distribution.Simple.Setup@+module Distribution.Simple.Setup.Benchmark+  ( BenchmarkFlags+      ( BenchmarkCommonFlags+      , benchmarkVerbosity+      , benchmarkDistPref+      , benchmarkCabalFilePath+      , benchmarkWorkingDir+      , benchmarkTargets+      , ..+      )+  , emptyBenchmarkFlags+  , defaultBenchmarkFlags+  , benchmarkCommand+  , benchmarkOptions'+  ) where++import Distribution.Compat.Prelude hiding (get)+import Prelude ()++import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import Distribution.Simple.InstallDirs+import Distribution.Simple.Setup.Common+import Distribution.Simple.Utils+import Distribution.Utils.Path+import Distribution.Verbosity++-- ------------------------------------------------------------++-- * Benchmark flags++-- ------------------------------------------------------------++data BenchmarkFlags = BenchmarkFlags+  { benchmarkCommonFlags :: !CommonSetupFlags+  , benchmarkOptions :: [PathTemplate]+  }+  deriving (Show, Generic)++pattern BenchmarkCommonFlags+  :: Flag Verbosity+  -> Flag (SymbolicPath Pkg (Dir Dist))+  -> Flag (SymbolicPath CWD (Dir Pkg))+  -> Flag (SymbolicPath Pkg File)+  -> [String]+  -> BenchmarkFlags+pattern BenchmarkCommonFlags+  { benchmarkVerbosity+  , benchmarkDistPref+  , benchmarkWorkingDir+  , benchmarkCabalFilePath+  , benchmarkTargets+  } <-+  ( benchmarkCommonFlags ->+      CommonSetupFlags+        { setupVerbosity = benchmarkVerbosity+        , setupDistPref = benchmarkDistPref+        , setupWorkingDir = benchmarkWorkingDir+        , setupCabalFilePath = benchmarkCabalFilePath+        , setupTargets = benchmarkTargets+        }+    )++instance Binary BenchmarkFlags+instance Structured BenchmarkFlags++defaultBenchmarkFlags :: BenchmarkFlags+defaultBenchmarkFlags =+  BenchmarkFlags+    { benchmarkCommonFlags = defaultCommonSetupFlags+    , benchmarkOptions = []+    }++benchmarkCommand :: CommandUI BenchmarkFlags+benchmarkCommand =+  CommandUI+    { commandName = "bench"+    , commandSynopsis =+        "Run all/specific benchmarks."+    , commandDescription = Just $ \_pname ->+        wrapText $+          testOrBenchmarkHelpText "benchmark"+    , commandNotes = Nothing+    , commandUsage =+        usageAlternatives+          "bench"+          [ "[FLAGS]"+          , "BENCHCOMPONENTS [FLAGS]"+          ]+    , commandDefaultFlags = defaultBenchmarkFlags+    , commandOptions = benchmarkOptions'+    }++benchmarkOptions' :: ShowOrParseArgs -> [OptionField BenchmarkFlags]+benchmarkOptions' showOrParseArgs =+  withCommonSetupOptions+    benchmarkCommonFlags+    (\c f -> f{benchmarkCommonFlags = c})+    showOrParseArgs+    [ option+        []+        ["benchmark-options"]+        ( "give extra options to benchmark executables "+            ++ "(split on spaces, use \"\" to prevent splitting; "+            ++ "name templates can use $pkgid, $compiler, "+            ++ "$os, $arch, $benchmark)"+        )+        benchmarkOptions+        (\v flags -> flags{benchmarkOptions = v})+        ( reqArg'+            "TEMPLATES"+            (map toPathTemplate . splitArgs)+            (const [])+        )+    , option+        []+        ["benchmark-option"]+        ( "give extra option to benchmark executables "+            ++ "(passed directly as a single argument; "+            ++ "name template can use $pkgid, $compiler, "+            ++ "$os, $arch, $benchmark)"+        )+        benchmarkOptions+        (\v flags -> flags{benchmarkOptions = v})+        ( reqArg'+            "TEMPLATE"+            (\x -> [toPathTemplate x])+            (map fromPathTemplate)+        )+    ]++emptyBenchmarkFlags :: BenchmarkFlags+emptyBenchmarkFlags = mempty++instance Monoid BenchmarkFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup BenchmarkFlags where+  (<>) = gmappend
+ src/Distribution/Simple/Setup/Build.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :  Distribution.Simple.Setup.Build+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Definition of the build command-line options.+-- See: @Distribution.Simple.Setup@+module Distribution.Simple.Setup.Build+  ( BuildFlags+      ( BuildCommonFlags+      , buildVerbosity+      , buildDistPref+      , buildCabalFilePath+      , buildWorkingDir+      , buildTargets+      , ..+      )+  , emptyBuildFlags+  , defaultBuildFlags+  , buildCommand+  , DumpBuildInfo (..)+  , buildOptions+  ) where++import Distribution.Compat.Prelude hiding (get)+import Prelude ()++import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import Distribution.Simple.Flag+import Distribution.Simple.Program+import Distribution.Simple.Setup.Common+import Distribution.Simple.Utils+import Distribution.Types.DumpBuildInfo+import Distribution.Utils.Path+import Distribution.Verbosity++-- ------------------------------------------------------------++-- * Build flags++-- ------------------------------------------------------------++data BuildFlags = BuildFlags+  { buildCommonFlags :: !CommonSetupFlags+  , buildProgramPaths :: [(String, FilePath)]+  , buildProgramArgs :: [(String, [String])]+  , buildNumJobs :: Flag (Maybe Int)+  , buildUseSemaphore :: Flag String+  }+  deriving (Read, Show, Generic)++pattern BuildCommonFlags+  :: Flag Verbosity+  -> Flag (SymbolicPath Pkg (Dir Dist))+  -> Flag (SymbolicPath CWD (Dir Pkg))+  -> Flag (SymbolicPath Pkg File)+  -> [String]+  -> BuildFlags+pattern BuildCommonFlags+  { buildVerbosity+  , buildDistPref+  , buildWorkingDir+  , buildCabalFilePath+  , buildTargets+  } <-+  ( buildCommonFlags ->+      CommonSetupFlags+        { setupVerbosity = buildVerbosity+        , setupDistPref = buildDistPref+        , setupWorkingDir = buildWorkingDir+        , setupCabalFilePath = buildCabalFilePath+        , setupTargets = buildTargets+        }+    )++instance Binary BuildFlags+instance Structured BuildFlags++defaultBuildFlags :: BuildFlags+defaultBuildFlags =+  BuildFlags+    { buildCommonFlags = defaultCommonSetupFlags+    , buildProgramPaths = mempty+    , buildProgramArgs = []+    , buildNumJobs = mempty+    , buildUseSemaphore = NoFlag+    }++buildCommand :: ProgramDb -> CommandUI BuildFlags+buildCommand progDb =+  CommandUI+    { commandName = "build"+    , commandSynopsis = "Compile all/specific components."+    , commandDescription = Just $ \_ ->+        wrapText $+          "Components encompass executables, tests, and benchmarks.\n"+            ++ "\n"+            ++ "Affected by configuration options, see `configure`.\n"+    , commandNotes = Just $ \pname ->+        "Examples:\n"+          ++ "  "+          ++ pname+          ++ " build           "+          ++ "    All the components in the package\n"+          ++ "  "+          ++ pname+          ++ " build foo       "+          ++ "    A component (i.e. lib, exe, test suite)\n\n"+          ++ programFlagsDescription progDb+    , -- TODO: re-enable once we have support for module/file targets+      --        ++ "  " ++ pname ++ " build Foo.Bar   "+      --        ++ "    A module\n"+      --        ++ "  " ++ pname ++ " build Foo/Bar.hs"+      --        ++ "    A file\n\n"+      --        ++ "If a target is ambiguous it can be qualified with the component "+      --        ++ "name, e.g.\n"+      --        ++ "  " ++ pname ++ " build foo:Foo.Bar\n"+      --        ++ "  " ++ pname ++ " build testsuite1:Foo/Bar.hs\n"+      commandUsage =+        usageAlternatives "build" $+          [ "[FLAGS]"+          , "COMPONENTS [FLAGS]"+          ]+    , commandDefaultFlags = defaultBuildFlags+    , commandOptions = buildOptions progDb+    }++buildOptions+  :: ProgramDb+  -> ShowOrParseArgs+  -> [OptionField BuildFlags]+buildOptions progDb showOrParseArgs =+  withCommonSetupOptions+    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)+      ]+    )+    ++ programDbPaths+      progDb+      showOrParseArgs+      buildProgramPaths+      (\v flags -> flags{buildProgramPaths = v})+    ++ programDbOption+      progDb+      showOrParseArgs+      buildProgramArgs+      (\v fs -> fs{buildProgramArgs = v})+    ++ programDbOptions+      progDb+      showOrParseArgs+      buildProgramArgs+      (\v flags -> flags{buildProgramArgs = v})++emptyBuildFlags :: BuildFlags+emptyBuildFlags = mempty++instance Monoid BuildFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup BuildFlags where+  (<>) = gmappend
+ src/Distribution/Simple/Setup/Clean.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :  Distribution.Simple.Setup.Clean+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Definition of the clean command-line options.+-- See: @Distribution.Simple.Setup@+module Distribution.Simple.Setup.Clean+  ( CleanFlags+      ( CleanCommonFlags+      , cleanVerbosity+      , cleanDistPref+      , cleanCabalFilePath+      , cleanWorkingDir+      , cleanTargets+      , ..+      )+  , emptyCleanFlags+  , defaultCleanFlags+  , cleanCommand+  ) where++import Distribution.Compat.Prelude hiding (get)+import Prelude ()++import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import Distribution.Simple.Flag+import Distribution.Simple.Setup.Common+import Distribution.Utils.Path+import Distribution.Verbosity++-- ------------------------------------------------------------++-- * Clean flags++-- ------------------------------------------------------------++data CleanFlags = CleanFlags+  { cleanCommonFlags :: !CommonSetupFlags+  , cleanSaveConf :: Flag Bool+  }+  deriving (Show, Generic)++pattern CleanCommonFlags+  :: Flag Verbosity+  -> Flag (SymbolicPath Pkg (Dir Dist))+  -> Flag (SymbolicPath CWD (Dir Pkg))+  -> Flag (SymbolicPath Pkg File)+  -> [String]+  -> CleanFlags+pattern CleanCommonFlags+  { cleanVerbosity+  , cleanDistPref+  , cleanWorkingDir+  , cleanCabalFilePath+  , cleanTargets+  } <-+  ( cleanCommonFlags ->+      CommonSetupFlags+        { setupVerbosity = cleanVerbosity+        , setupDistPref = cleanDistPref+        , setupWorkingDir = cleanWorkingDir+        , setupCabalFilePath = cleanCabalFilePath+        , setupTargets = cleanTargets+        }+    )++instance Binary CleanFlags+instance Structured CleanFlags++defaultCleanFlags :: CleanFlags+defaultCleanFlags =+  CleanFlags+    { cleanCommonFlags = defaultCommonSetupFlags+    , cleanSaveConf = Flag False+    }++cleanCommand :: CommandUI CleanFlags+cleanCommand =+  CommandUI+    { commandName = "clean"+    , commandSynopsis = "Clean up after a build."+    , commandDescription = Just $ \_ ->+        "Removes .hi, .o, preprocessed sources, etc.\n"+    , commandNotes = Nothing+    , commandUsage = \pname ->+        "Usage: " ++ pname ++ " clean [FLAGS]\n"+    , commandDefaultFlags = defaultCleanFlags+    , commandOptions = \showOrParseArgs ->+        withCommonSetupOptions+          cleanCommonFlags+          (\c f -> f{cleanCommonFlags = c})+          showOrParseArgs+          [ option+              "s"+              ["save-configure"]+              "Do not remove the configuration file (dist/setup-config) during cleaning.  Saves need to reconfigure."+              cleanSaveConf+              (\v flags -> flags{cleanSaveConf = v})+              trueArg+          ]+    }++emptyCleanFlags :: CleanFlags+emptyCleanFlags = mempty++instance Monoid CleanFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup CleanFlags where+  (<>) = gmappend
+ src/Distribution/Simple/Setup/Common.hs view
@@ -0,0 +1,499 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module      :  Distribution.Simple.Setup.Common+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Common utilities for defining command-line options.+-- See: @Distribution.Simple.Setup@+module Distribution.Simple.Setup.Common+  ( CommonSetupFlags (..)+  , defaultCommonSetupFlags+  , withCommonSetupOptions+  , commonSetupTempFileOptions+  , CopyDest (..)+  , configureCCompiler+  , configureLinker+  , programDbOption+  , programDbOptions+  , programDbPaths+  , programDbPaths'+  , programFlagsDescription+  , splitArgs+  , testOrBenchmarkHelpText+  , defaultDistPref+  , extraCompilationArtifacts+  , optionDistPref+  , Flag+  , pattern Flag+  , pattern NoFlag+  , toFlag+  , fromFlag+  , fromFlagOrDefault+  , flagToMaybe+  , flagToList+  , maybeToFlag+  , BooleanFlag (..)+  , boolOpt+  , boolOpt'+  , trueArg+  , falseArg+  , reqArgFlag+  , reqSymbolicPathArgFlag+  , optionVerbosity+  , optionNumJobs+  ) where++import Distribution.Compat.Prelude hiding (get)+import Prelude ()++import Distribution.ReadE+import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import qualified Distribution.Simple.Command as Command+import Distribution.Simple.Flag+import Distribution.Simple.InstallDirs+import Distribution.Simple.Program+import Distribution.Simple.Utils+import Distribution.Utils.Path+import Distribution.Verbosity++--------------------------------------------------------------------------------++-- | A datatype that stores common flags for different invocations+-- of a @Setup@ executable, e.g. configure, build, install.+data CommonSetupFlags = CommonSetupFlags+  { setupVerbosity :: !(Flag Verbosity)+  -- ^ Verbosity+  , setupWorkingDir :: !(Flag (SymbolicPath CWD (Dir Pkg)))+  -- ^ Working directory (optional)+  , setupDistPref :: !(Flag (SymbolicPath Pkg (Dir Dist)))+  -- ^ Build directory+  , setupCabalFilePath :: !(Flag (SymbolicPath Pkg File))+  -- ^ Which Cabal file to use (optional)+  , setupTargets :: [String]+  -- ^ Which targets is this Setup invocation relative to?+  --+  -- TODO: this one should not be here, it's just that the silly+  -- UserHooks stop us from passing extra info in other ways+  , setupKeepTempFiles :: Flag Bool+  -- ^ When this flag is set, temporary files will be kept after building.+  --+  -- Note: Keeping temporary files is important functionality for HLS, which+  -- runs @cabal repl@ with a fake GHC to get CLI arguments. It will need the+  -- temporary files (including multi unit repl response files) to stay, even+  -- after the @cabal repl@ command exits.+  }+  deriving (Eq, Show, Read, Generic)++instance Binary CommonSetupFlags+instance Structured CommonSetupFlags++instance Semigroup CommonSetupFlags where+  (<>) = gmappend++instance Monoid CommonSetupFlags where+  mempty = gmempty+  mappend = (<>)++defaultCommonSetupFlags :: CommonSetupFlags+defaultCommonSetupFlags =+  CommonSetupFlags+    { setupVerbosity = Flag normal+    , setupWorkingDir = NoFlag+    , setupDistPref = NoFlag+    , setupCabalFilePath = NoFlag+    , setupTargets = []+    , setupKeepTempFiles = NoFlag+    }++-- | Get `TempFileOptions` that respect the `setupKeepTempFiles` flag.+commonSetupTempFileOptions :: CommonSetupFlags -> TempFileOptions+commonSetupTempFileOptions options =+  TempFileOptions+    { optKeepTempFiles =+        fromFlagOrDefault False (setupKeepTempFiles options)+    }++commonSetupOptions :: ShowOrParseArgs -> [OptionField CommonSetupFlags]+commonSetupOptions showOrParseArgs =+  [ optionVerbosity+      setupVerbosity+      (\v flags -> flags{setupVerbosity = v})+  , optionDistPref+      setupDistPref+      (\d flags -> flags{setupDistPref = d})+      showOrParseArgs+  , option+      ""+      ["cabal-file"]+      "use this Cabal file"+      setupCabalFilePath+      (\v flags -> flags{setupCabalFilePath = v})+      (reqSymbolicPathArgFlag "PATH")+  , option+      ""+      ["keep-temp-files"]+      ( "Keep temporary files."+      )+      setupKeepTempFiles+      (\keepTempFiles flags -> flags{setupKeepTempFiles = keepTempFiles})+      trueArg+      -- NB: no --working-dir flag, as that value is populated using the+      -- global flag (see Distribution.Simple.Setup.Global.globalCommand).+  ]++withCommonSetupOptions+  :: (flags -> CommonSetupFlags)+  -> (CommonSetupFlags -> flags -> flags)+  -> ShowOrParseArgs+  -> [OptionField flags]+  -> [OptionField flags]+withCommonSetupOptions getCommon setCommon showOrParseArgs opts =+  map fmapOptionField (commonSetupOptions showOrParseArgs) ++ opts+  where+    fmapOptionField (OptionField nm descr) =+      OptionField nm (map (fmapOptDescr getCommon setCommon) descr)++--------------------------------------------------------------------------------++-- FIXME Not sure where this should live+defaultDistPref :: SymbolicPath Pkg (Dir Dist)+defaultDistPref = makeSymbolicPath "dist"++-- | The name of the directory where optional compilation artifacts+-- go, such as ghc plugins and .hie files.+extraCompilationArtifacts :: RelativePath Build (Dir Artifacts)+extraCompilationArtifacts = makeRelativePathEx "extra-compilation-artifacts"++-- | Help text for @test@ and @bench@ commands.+testOrBenchmarkHelpText+  :: String+  -- ^ Either @"test"@ or @"benchmark"@.+  -> String+  -- ^ Help text.+testOrBenchmarkHelpText s =+  unlines $+    map+      unwords+      [+        [ "The package must have been build with configuration"+        , concat ["flag `--enable-", s, "s`."]+        ]+      , [] -- blank line+      ,+        [ concat ["Note that additional dependencies of the ", s, "s"]+        , "must have already been installed."+        ]+      , []+      ,+        [ "By defining UserHooks in a custom Setup.hs, the package can define"+        , concat ["actions to be executed before and after running ", s, "s."]+        ]+      ]++-- ------------------------------------------------------------++-- * Shared options utils++-- ------------------------------------------------------------++programFlagsDescription :: ProgramDb -> String+programFlagsDescription progDb =+  "The flags --with-PROG and --PROG-option(s) can be used with"+    ++ " the following programs:"+    ++ (concatMap (\line -> "\n  " ++ unwords line) . wrapLine 77 . sort)+      [programName prog | (prog, _) <- knownPrograms progDb]+    ++ "\n"++-- | For each known program @PROG@ in 'progDb', produce a @with-PROG@+-- 'OptionField'.+programDbPaths+  :: ProgramDb+  -> ShowOrParseArgs+  -> (flags -> [(String, FilePath)])+  -> ([(String, FilePath)] -> (flags -> flags))+  -> [OptionField flags]+programDbPaths progDb showOrParseArgs get set =+  programDbPaths' ("with-" ++) progDb showOrParseArgs get set++-- | Like 'programDbPaths', but allows to customise the option name.+programDbPaths'+  :: (String -> String)+  -> ProgramDb+  -> ShowOrParseArgs+  -> (flags -> [(String, FilePath)])+  -> ([(String, FilePath)] -> (flags -> flags))+  -> [OptionField flags]+programDbPaths' mkName progDb showOrParseArgs get set =+  case showOrParseArgs of+    -- we don't want a verbose help text list so we just show a generic one:+    ShowArgs -> [withProgramPath "PROG"]+    ParseArgs ->+      map+        (withProgramPath . programName . fst)+        (knownPrograms progDb)+  where+    withProgramPath prog =+      option+        ""+        [mkName prog]+        ("give the path to " ++ prog)+        get+        set+        ( reqArg'+            "PATH"+            (\path -> [(prog, path)])+            (\progPaths -> [path | (prog', path) <- progPaths, prog == prog'])+        )++-- | For each known program @PROG@ in 'progDb', produce a @PROG-option@+-- 'OptionField'.+programDbOption+  :: ProgramDb+  -> ShowOrParseArgs+  -> (flags -> [(String, [String])])+  -> ([(String, [String])] -> (flags -> flags))+  -> [OptionField flags]+programDbOption progDb showOrParseArgs get set =+  case showOrParseArgs of+    -- we don't want a verbose help text list so we just show a generic one:+    ShowArgs -> [programOption "PROG"]+    ParseArgs ->+      map+        (programOption . programName . fst)+        (knownPrograms progDb)+  where+    programOption prog =+      option+        ""+        [prog ++ "-option"]+        ( "give an extra option to "+            ++ prog+            ++ " (passed directly to "+            ++ prog+            ++ " as a single argument)"+        )+        get+        set+        ( reqArg'+            "OPT"+            (\arg -> [(prog, [arg])])+            ( \progArgs ->+                concat+                  [ args+                  | (prog', args) <- progArgs+                  , prog == prog'+                  ]+            )+        )++-- | For each known program @PROG@ in 'progDb', produce a @PROG-options@+-- 'OptionField'.+programDbOptions+  :: ProgramDb+  -> ShowOrParseArgs+  -> (flags -> [(String, [String])])+  -> ([(String, [String])] -> (flags -> flags))+  -> [OptionField flags]+programDbOptions progDb showOrParseArgs get set =+  case showOrParseArgs of+    -- we don't want a verbose help text list so we just show a generic one:+    ShowArgs -> [programOptions "PROG"]+    ParseArgs ->+      map+        (programOptions . programName . fst)+        (knownPrograms progDb)+  where+    programOptions prog =+      option+        ""+        [prog ++ "-options"]+        ( "give extra options to "+            ++ prog+            ++ " (split on spaces, use \"\" to prevent splitting)"+        )+        get+        set+        (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))++-- ------------------------------------------------------------++-- * GetOpt Utils++-- ------------------------------------------------------------++boolOpt+  :: SFlags+  -> SFlags+  -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a+boolOpt = Command.boolOpt flagToMaybe Flag++boolOpt'+  :: OptFlags+  -> OptFlags+  -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a+boolOpt' = Command.boolOpt' flagToMaybe Flag++trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a+trueArg sfT lfT = boolOpt' (sfT, lfT) ([], []) sfT lfT+falseArg sfF lfF = boolOpt' ([], []) (sfF, lfF) sfF lfF++reqArgFlag+  :: ArgPlaceHolder+  -> SFlags+  -> LFlags+  -> Description+  -> (b -> Flag String)+  -> (Flag String -> b -> b)+  -> OptDescr b+reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList++optionDistPref+  :: (flags -> Flag (SymbolicPath Pkg (Dir Dist)))+  -> (Flag (SymbolicPath Pkg (Dir Dist)) -> flags -> flags)+  -> ShowOrParseArgs+  -> OptionField flags+optionDistPref get set = \showOrParseArgs ->+  option+    ""+    (distPrefFlagName showOrParseArgs)+    ( "The directory where Cabal puts generated build files "+        ++ "(default "+        ++ getSymbolicPath defaultDistPref+        ++ ")"+    )+    get+    set+    (reqSymbolicPathArgFlag "DIR")+  where+    distPrefFlagName ShowArgs = ["builddir"]+    distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"]++reqSymbolicPathArgFlag+  :: ArgPlaceHolder+  -> SFlags+  -> LFlags+  -> Description+  -> (b -> Flag (SymbolicPath from to))+  -> (Flag (SymbolicPath from to) -> b -> b)+  -> OptDescr b+reqSymbolicPathArgFlag title sf lf d get set =+  reqArgFlag+    title+    sf+    lf+    d+    (fmap getSymbolicPath . get)+    (set . fmap makeSymbolicPath)++optionVerbosity+  :: (flags -> Flag Verbosity)+  -> (Flag Verbosity -> flags -> flags)+  -> OptionField flags+optionVerbosity get set =+  option+    "v"+    ["verbose"]+    "Control verbosity (n is 0--3, default verbosity level is 1)"+    get+    set+    ( optArg+        "n"+        (fmap Flag flagToVerbosity)+        (show verbose, Flag verbose) -- default Value if no n is given+        (fmap (Just . showForCabal) . flagToList)+    )++optionNumJobs+  :: (flags -> Flag (Maybe Int))+  -> (Flag (Maybe Int) -> flags -> flags)+  -> OptionField flags+optionNumJobs get set =+  option+    "j"+    ["jobs"]+    "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."+    get+    set+    ( optArg+        "NUM"+        (fmap Flag numJobsParser)+        ("$ncpus", Flag Nothing)+        (map (Just . maybe "$ncpus" show) . flagToList)+    )+  where+    numJobsParser :: ReadE (Maybe Int)+    numJobsParser = ReadE $ \s ->+      case s of+        "$ncpus" -> Right Nothing+        _ -> case reads s of+          [(n, "")]+            | n < 1 -> Left "The number of jobs should be 1 or more."+            | otherwise -> Right (Just n)+          _ -> Left "The jobs value should be a number or '$ncpus'"++-- ------------------------------------------------------------++-- * Other Utils++-- ------------------------------------------------------------++configureCCompiler+  :: Verbosity+  -> ProgramDb+  -> IO (FilePath, [String])+configureCCompiler verbosity progdb = configureProg verbosity progdb gccProgram++configureLinker :: Verbosity -> ProgramDb -> IO (FilePath, [String])+configureLinker verbosity progdb = configureProg verbosity progdb ldProgram++configureProg+  :: Verbosity+  -> ProgramDb+  -> Program+  -> IO (FilePath, [String])+configureProg verbosity programDb prog = do+  (p, _) <- requireProgram verbosity prog programDb+  let pInv = programInvocation p []+  return (progInvokePath pInv, progInvokeArgs pInv)++-- | Helper function to split a string into a list of arguments.+-- It's supposed to handle quoted things sensibly, eg:+--+-- > splitArgs "--foo=\"C:/Program Files/Bar/" --baz"+-- >   = ["--foo=C:/Program Files/Bar", "--baz"]+--+-- > splitArgs "\"-DMSGSTR=\\\"foo bar\\\"\" --baz"+-- >   = ["-DMSGSTR=\"foo bar\"","--baz"]+splitArgs :: String -> [String]+splitArgs = space []+  where+    space :: String -> String -> [String]+    space w [] = word w []+    space w (c : s)+      | isSpace c = word w (space [] s)+    space w ('"' : s) = string w s+    space w s = nonstring w s++    string :: String -> String -> [String]+    string w [] = word w []+    string w ('"' : s) = space w s+    string w ('\\' : '"' : s) = string ('"' : w) s+    string w (c : s) = string (c : w) s++    nonstring :: String -> String -> [String]+    nonstring w [] = word w []+    nonstring w ('"' : s) = string w s+    nonstring w (c : s) = space (c : w) s++    word [] s = s+    word w s = reverse w : s
+ src/Distribution/Simple/Setup/Config.hs view
@@ -0,0 +1,1109 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Setup.Config+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Definition of the configure command-line options.+-- See: @Distribution.Simple.Setup@+module Distribution.Simple.Setup.Config+  ( ConfigFlags+      ( ConfigCommonFlags+      , configVerbosity+      , configDistPref+      , configCabalFilePath+      , configWorkingDir+      , configTargets+      , ..+      )+  , emptyConfigFlags+  , defaultConfigFlags+  , configureCommand+  , configPrograms+  , readPackageDb+  , readPackageDbList+  , showPackageDb+  , showPackageDbList+  , configureArgs+  , configureOptions+  , installDirsOptions+  ) where++import Distribution.Compat.Prelude hiding (get)+import Prelude ()++import qualified Distribution.Compat.CharParsing as P+import Distribution.Compat.Semigroup (Last' (..), Option' (..))+import Distribution.Compat.Stack+import Distribution.Compiler+import Distribution.ModuleName+import Distribution.PackageDescription+import Distribution.Parsec+import Distribution.Pretty+import Distribution.ReadE+import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import Distribution.Simple.Compiler+import Distribution.Simple.Flag+import Distribution.Simple.InstallDirs+import Distribution.Simple.Program+import Distribution.Simple.Setup.Common+import Distribution.Simple.Utils+import Distribution.Types.ComponentId+import Distribution.Types.DumpBuildInfo+import Distribution.Types.GivenComponent+import Distribution.Types.Module+import Distribution.Types.PackageVersionConstraint+import Distribution.Types.UnitId+import Distribution.Utils.NubList+import Distribution.Utils.Path+import Distribution.Verbosity++import qualified Text.PrettyPrint as Disp++-- ------------------------------------------------------------++-- * Config flags++-- ------------------------------------------------------------++-- | Flags to @configure@ command.+--+-- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags'+-- should be updated.+-- IMPORTANT: every time a new flag is added, it should be added to the Eq instance+data ConfigFlags = ConfigFlags+  { configCommonFlags :: !CommonSetupFlags+  , -- FIXME: the configPrograms is only here to pass info through to configure+    -- because the type of configure is constrained by the UserHooks.+    -- when we change UserHooks next we should pass the initial+    -- ProgramDb directly and not via ConfigFlags+    configPrograms_ :: Option' (Last' ProgramDb)+  -- ^ All programs that+  --  @cabal@ may run+  , configProgramPaths :: [(String, FilePath)]+  -- ^ user specified programs paths+  , configProgramArgs :: [(String, [String])]+  -- ^ user specified programs args+  , configProgramPathExtra :: NubList FilePath+  -- ^ Extend the $PATH+  , configHcFlavor :: Flag CompilerFlavor+  -- ^ The \"flavor\" of the+  --  compiler, e.g. GHC.+  , configHcPath :: Flag FilePath+  -- ^ given compiler location+  , configHcPkg :: Flag FilePath+  -- ^ given hc-pkg location+  , configVanillaLib :: Flag Bool+  -- ^ Enable vanilla library+  , configProfLib :: Flag Bool+  -- ^ Enable profiling in the library+  , configSharedLib :: Flag Bool+  -- ^ Build shared library+  , configStaticLib :: Flag Bool+  -- ^ Build static library+  , configDynExe :: Flag Bool+  -- ^ Enable dynamic linking of the+  --  executables.+  , configFullyStaticExe :: Flag Bool+  -- ^ Enable fully static linking of the+  --  executables.+  , configProfExe :: Flag Bool+  -- ^ Enable profiling in the+  --  executables.+  , configProf :: Flag Bool+  -- ^ Enable profiling in the library+  --  and executables.+  , configProfShared :: Flag Bool+  -- ^ Enable shared profiling objects+  , configProfDetail :: Flag ProfDetailLevel+  -- ^ Profiling detail level+  --   in the library and executables.+  , configProfLibDetail :: Flag ProfDetailLevel+  -- ^ Profiling  detail level+  --  in the library+  , configConfigureArgs :: [String]+  -- ^ Extra arguments to @configure@+  , configOptimization :: Flag OptimisationLevel+  -- ^ Enable optimization.+  , configProgPrefix :: Flag PathTemplate+  -- ^ Installed executable prefix.+  , configProgSuffix :: Flag PathTemplate+  -- ^ Installed executable suffix.+  , configInstallDirs :: InstallDirs (Flag PathTemplate)+  -- ^ Installation+  --  paths+  , configScratchDir :: Flag FilePath+  , configExtraLibDirs :: [SymbolicPath Pkg (Dir Lib)]+  -- ^ path to search for extra libraries+  , configExtraLibDirsStatic :: [SymbolicPath Pkg (Dir Lib)]+  -- ^ path to search for extra+  --   libraries when linking+  --   fully static executables+  , configExtraFrameworkDirs :: [SymbolicPath Pkg (Dir Framework)]+  -- ^ path to search for extra+  -- frameworks (OS X only)+  , configExtraIncludeDirs :: [SymbolicPath Pkg (Dir Include)]+  -- ^ path to search for header files+  , configIPID :: Flag String+  -- ^ explicit IPID to be used+  , configCID :: Flag ComponentId+  -- ^ explicit CID to be used+  , configDeterministic :: Flag Bool+  -- ^ be as deterministic as possible+  -- (e.g., invariant over GHC, database,+  -- etc).  Used by the test suite+  , configUserInstall :: Flag Bool+  -- ^ The --user\/--global flag+  , configPackageDBs :: [Maybe PackageDB]+  -- ^ Which package DBs to use+  , configGHCiLib :: Flag Bool+  -- ^ Enable compiling library for GHCi+  , configSplitSections :: Flag Bool+  -- ^ Enable -split-sections with GHC+  , configSplitObjs :: Flag Bool+  -- ^ Enable -split-objs with GHC+  , configStripExes :: Flag Bool+  -- ^ Enable executable stripping+  , configStripLibs :: Flag Bool+  -- ^ Enable library stripping+  , configConstraints :: [PackageVersionConstraint]+  -- ^ Additional constraints for+  --  dependencies.+  , configDependencies :: [GivenComponent]+  -- ^ The packages depended on which already exist+  , configPromisedDependencies :: [PromisedComponent]+  -- ^ The packages depended on which doesn't yet exist (i.e. promised).+  --  Promising dependencies enables us to configure components in parallel,+  --  and avoids expensive builds if they are not necessary.+  --  For example, in multi-repl mode, we don't want to build dependencies that+  --  are loaded into the interactive session, since we have to build them again.+  , configInstantiateWith :: [(ModuleName, Module)]+  -- ^ The requested Backpack instantiation.  If empty, either this+  -- package does not use Backpack, or we just want to typecheck+  -- the indefinite package.+  , configConfigurationsFlags :: FlagAssignment+  , configTests :: Flag Bool+  -- ^ Enable test suite compilation+  , configBenchmarks :: Flag Bool+  -- ^ Enable benchmark compilation+  , configCoverage :: Flag Bool+  -- ^ Enable program coverage+  , configLibCoverage :: Flag Bool+  -- ^ Enable program coverage (deprecated)+  , configExactConfiguration :: Flag Bool+  -- ^ All direct dependencies and flags are provided on the command line by+  --  the user via the '--dependency' and '--flags' options.+  , configFlagError :: Flag String+  -- ^ Halt and show an error message indicating an error in flag assignment+  , configRelocatable :: Flag Bool+  -- ^ Enable relocatable package built+  , configDebugInfo :: Flag DebugInfoLevel+  -- ^ Emit debug info.+  , configDumpBuildInfo :: Flag DumpBuildInfo+  -- ^ Should we dump available build information on build?+  -- Dump build information to disk before attempting to build,+  -- tooling can parse these files and use them to compile the+  -- source files themselves.+  , configUseResponseFiles :: Flag Bool+  -- ^ Whether to use response files at all. They're used for such tools+  -- as haddock, or ld.+  , configAllowDependingOnPrivateLibs :: Flag Bool+  -- ^ Allow depending on private sublibraries. This is used by external+  -- tools (like cabal-install) so they can add multiple-public-libraries+  -- compatibility to older ghcs by checking visibility externally.+  , configCoverageFor :: Flag [UnitId]+  -- ^ The list of libraries to be included in the hpc coverage report for+  -- testsuites run with @--enable-coverage@. Notably, this list must exclude+  -- indefinite libraries and instantiations because HPC does not support+  -- backpack (Nov. 2023).+  , configIgnoreBuildTools :: Flag Bool+  -- ^ When this flag is set, all tools declared in `build-tool`s and+  -- `build-tool-depends` will be ignored. This allows a Cabal package with+  -- build-tool-dependencies to be built even if the tool is not found.+  }+  deriving (Generic, Read, Show)++pattern ConfigCommonFlags+  :: Flag Verbosity+  -> Flag (SymbolicPath Pkg (Dir Dist))+  -> Flag (SymbolicPath CWD (Dir Pkg))+  -> Flag (SymbolicPath Pkg File)+  -> [String]+  -> ConfigFlags+pattern ConfigCommonFlags+  { configVerbosity+  , configDistPref+  , configWorkingDir+  , configCabalFilePath+  , configTargets+  } <-+  ( configCommonFlags ->+      CommonSetupFlags+        { setupVerbosity = configVerbosity+        , setupDistPref = configDistPref+        , setupWorkingDir = configWorkingDir+        , setupCabalFilePath = configCabalFilePath+        , setupTargets = configTargets+        }+    )++instance Binary ConfigFlags+instance Structured ConfigFlags++-- | More convenient version of 'configPrograms'. Results in an+-- 'error' if internal invariant is violated.+configPrograms :: WithCallStack (ConfigFlags -> ProgramDb)+configPrograms =+  fromMaybe (error "FIXME: remove configPrograms")+    . fmap getLast'+    . getOption'+    . configPrograms_++instance Eq ConfigFlags where+  (==) a b =+    -- configPrograms skipped: not user specified, has no Eq instance+    equal configCommonFlags+      && equal configProgramPaths+      && equal configProgramArgs+      && equal configProgramPathExtra+      && equal configHcFlavor+      && equal configHcPath+      && equal configHcPkg+      && equal configVanillaLib+      && equal configProfLib+      && equal configSharedLib+      && equal configStaticLib+      && equal configDynExe+      && equal configFullyStaticExe+      && equal configProfExe+      && equal configProf+      && equal configProfDetail+      && equal configProfShared+      && equal configProfLibDetail+      && equal configConfigureArgs+      && equal configOptimization+      && equal configProgPrefix+      && equal configProgSuffix+      && equal configInstallDirs+      && equal configScratchDir+      && equal configExtraLibDirs+      && equal configExtraLibDirsStatic+      && equal configExtraIncludeDirs+      && equal configIPID+      && equal configDeterministic+      && equal configUserInstall+      && equal configPackageDBs+      && equal configGHCiLib+      && equal configSplitSections+      && equal configSplitObjs+      && equal configStripExes+      && equal configStripLibs+      && equal configConstraints+      && equal configDependencies+      && equal configPromisedDependencies+      && equal configConfigurationsFlags+      && equal configTests+      && equal configBenchmarks+      && equal configCoverage+      && equal configLibCoverage+      && equal configExactConfiguration+      && equal configFlagError+      && equal configRelocatable+      && equal configDebugInfo+      && equal configDumpBuildInfo+      && equal configUseResponseFiles+      && equal configAllowDependingOnPrivateLibs+      && equal configCoverageFor+      && equal configIgnoreBuildTools+    where+      equal f = on (==) f a b++{- FOURMOLU_DISABLE -}+defaultConfigFlags :: ProgramDb -> ConfigFlags+defaultConfigFlags progDb =+  emptyConfigFlags+    { configCommonFlags = defaultCommonSetupFlags+    , configPrograms_ = Option' (Just (Last' progDb))+    , configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor+    , configVanillaLib = Flag True+    , configProfLib = NoFlag+    , configSharedLib = NoFlag+    , configStaticLib = NoFlag+    , configDynExe = Flag False+    , configFullyStaticExe = Flag False+    , configProfExe = NoFlag+    , configProf = NoFlag+    , configProfDetail = NoFlag+    , configProfLibDetail = NoFlag+    , configOptimization = Flag NormalOptimisation+    , configProgPrefix = Flag (toPathTemplate "")+    , configProgSuffix = Flag (toPathTemplate "")+    , configUserInstall = Flag False -- TODO: reverse this+#if defined(mingw32_HOST_OS)+        -- See #8062 and GHC #21019.+    , configGHCiLib = Flag False+#else+    , configGHCiLib = NoFlag+#endif+    , configSplitSections = Flag False+    , configSplitObjs = Flag False -- takes longer, so turn off by default+    , configStripExes = NoFlag+    , configStripLibs = NoFlag+    , configTests = Flag False+    , configBenchmarks = Flag False+    , configCoverage = Flag False+    , configLibCoverage = NoFlag+    , configExactConfiguration = Flag False+    , configFlagError = NoFlag+    , configRelocatable = Flag False+    , configDebugInfo = Flag NoDebugInfo+    , configDumpBuildInfo = NoFlag+    , configUseResponseFiles = NoFlag+    }+{- FOURMOLU_ENABLE -}++configureCommand :: ProgramDb -> CommandUI ConfigFlags+configureCommand progDb =+  CommandUI+    { commandName = "configure"+    , commandSynopsis = "Prepare to build the package."+    , commandDescription = Just $ \_ ->+        wrapText $+          "Configure how the package is built by setting "+            ++ "package (and other) flags.\n"+            ++ "\n"+            ++ "The configuration affects several other commands, "+            ++ "including build, test, bench, run, repl.\n"+    , commandNotes = Just $ \_pname -> programFlagsDescription progDb+    , commandUsage = \pname ->+        "Usage: " ++ pname ++ " configure [FLAGS]\n"+    , commandDefaultFlags = defaultConfigFlags progDb+    , commandOptions = \showOrParseArgs ->+        configureOptions showOrParseArgs+          ++ programDbPaths+            progDb+            showOrParseArgs+            configProgramPaths+            (\v fs -> fs{configProgramPaths = v})+          ++ programDbOption+            progDb+            showOrParseArgs+            configProgramArgs+            (\v fs -> fs{configProgramArgs = v})+          ++ programDbOptions+            progDb+            showOrParseArgs+            configProgramArgs+            (\v fs -> fs{configProgramArgs = v})+    }++-- | Inverse to 'dispModSubstEntry'.+parsecModSubstEntry :: ParsecParser (ModuleName, Module)+parsecModSubstEntry = do+  k <- parsec+  _ <- P.char '='+  v <- parsec+  return (k, v)++-- | Pretty-print a single entry of a module substitution.+dispModSubstEntry :: (ModuleName, Module) -> Disp.Doc+dispModSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v++configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags]+configureOptions showOrParseArgs =+  withCommonSetupOptions+    configCommonFlags+    (\c f -> f{configCommonFlags = c})+    showOrParseArgs+    [ option+        []+        ["compiler"]+        "compiler"+        configHcFlavor+        (\v flags -> flags{configHcFlavor = v})+        ( choiceOpt+            [ (Flag GHC, ("g", ["ghc"]), "compile with GHC")+            , (Flag GHCJS, ([], ["ghcjs"]), "compile with GHCJS")+            , (Flag UHC, ([], ["uhc"]), "compile with UHC")+            ]+        )+    , option+        "w"+        ["with-compiler"]+        "give the path to a particular compiler"+        configHcPath+        (\v flags -> flags{configHcPath = v})+        (reqArgFlag "PATH")+    , option+        ""+        ["with-hc-pkg"]+        "give the path to the package tool"+        configHcPkg+        (\v flags -> flags{configHcPkg = v})+        (reqArgFlag "PATH")+    ]+    ++ map liftInstallDirs installDirsOptions+    ++ [ option+          ""+          ["program-prefix"]+          "prefix to be applied to installed executables"+          configProgPrefix+          (\v flags -> flags{configProgPrefix = v})+          (reqPathTemplateArgFlag "PREFIX")+       , option+          ""+          ["program-suffix"]+          "suffix to be applied to installed executables"+          configProgSuffix+          (\v flags -> flags{configProgSuffix = v})+          (reqPathTemplateArgFlag "SUFFIX")+       , option+          ""+          ["library-vanilla"]+          "Vanilla libraries"+          configVanillaLib+          (\v flags -> flags{configVanillaLib = v})+          (boolOpt [] [])+       , option+          "p"+          ["library-profiling"]+          "Library profiling"+          configProfLib+          (\v flags -> flags{configProfLib = v})+          (boolOpt "p" [])+       , option+          ""+          ["shared"]+          "Shared library"+          configSharedLib+          (\v flags -> flags{configSharedLib = v})+          (boolOpt [] [])+       , option+          ""+          ["static"]+          "Static library"+          configStaticLib+          (\v flags -> flags{configStaticLib = v})+          (boolOpt [] [])+       , option+          ""+          ["executable-dynamic"]+          "Executable dynamic linking"+          configDynExe+          (\v flags -> flags{configDynExe = v})+          (boolOpt [] [])+       , option+          ""+          ["executable-static"]+          "Executable fully static linking"+          configFullyStaticExe+          (\v flags -> flags{configFullyStaticExe = v})+          (boolOpt [] [])+       , option+          ""+          ["profiling"]+          "Executable and library profiling"+          configProf+          (\v flags -> flags{configProf = v})+          (boolOpt [] [])+       , option+          ""+          ["profiling-shared"]+          "Build profiling shared libraries"+          configProfShared+          (\v flags -> flags{configProfShared = v})+          (boolOpt [] [])+       , option+          ""+          ["executable-profiling"]+          "Executable profiling (DEPRECATED)"+          configProfExe+          (\v flags -> flags{configProfExe = v})+          (boolOpt [] [])+       , option+          ""+          ["profiling-detail"]+          ( "Profiling detail level for executable and library (default, "+              ++ "none, exported-functions, toplevel-functions,  all-functions, late)."+          )+          configProfDetail+          (\v flags -> flags{configProfDetail = v})+          ( reqArg'+              "level"+              (Flag . flagToProfDetailLevel)+              showProfDetailLevelFlag+          )+       , option+          ""+          ["library-profiling-detail"]+          "Profiling detail level for libraries only."+          configProfLibDetail+          (\v flags -> flags{configProfLibDetail = v})+          ( reqArg'+              "level"+              (Flag . flagToProfDetailLevel)+              showProfDetailLevelFlag+          )+       , multiOption+          "optimization"+          configOptimization+          (\v flags -> flags{configOptimization = v})+          [ optArgDef'+              "n"+              (show NoOptimisation, Flag . flagToOptimisationLevel)+              ( \f -> case f of+                  Flag NoOptimisation -> []+                  Flag NormalOptimisation -> [Nothing]+                  Flag MaximumOptimisation -> [Just "2"]+                  _ -> []+              )+              "O"+              ["enable-optimization", "enable-optimisation"]+              "Build with optimization (n is 0--2, default is 1)"+          , noArg+              (Flag NoOptimisation)+              []+              ["disable-optimization", "disable-optimisation"]+              "Build without optimization"+          ]+       , multiOption+          "debug-info"+          configDebugInfo+          (\v flags -> flags{configDebugInfo = v})+          [ optArg'+              "n"+              (Flag . flagToDebugInfoLevel)+              ( \f -> case f of+                  Flag NoDebugInfo -> []+                  Flag MinimalDebugInfo -> [Just "1"]+                  Flag NormalDebugInfo -> [Nothing]+                  Flag MaximalDebugInfo -> [Just "3"]+                  _ -> []+              )+              ""+              ["enable-debug-info"]+              "Emit debug info (n is 0--3, default is 0)"+          , noArg+              (Flag NoDebugInfo)+              []+              ["disable-debug-info"]+              "Don't emit debug info"+          ]+       , multiOption+          "build-info"+          configDumpBuildInfo+          (\v flags -> flags{configDumpBuildInfo = v})+          [ noArg+              (Flag DumpBuildInfo)+              []+              ["enable-build-info"]+              "Enable build information generation during project building"+          , noArg+              (Flag NoDumpBuildInfo)+              []+              ["disable-build-info"]+              "Disable build information generation during project building"+          ]+       , option+          ""+          ["library-for-ghci"]+          "compile library for use with GHCi"+          configGHCiLib+          (\v flags -> flags{configGHCiLib = v})+          (boolOpt [] [])+       , option+          ""+          ["split-sections"]+          "compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)"+          configSplitSections+          (\v flags -> flags{configSplitSections = v})+          (boolOpt [] [])+       , option+          ""+          ["split-objs"]+          "split library into smaller objects to reduce binary sizes (GHC 6.6+)"+          configSplitObjs+          (\v flags -> flags{configSplitObjs = v})+          (boolOpt [] [])+       , option+          ""+          ["executable-stripping"]+          "strip executables upon installation to reduce binary sizes"+          configStripExes+          (\v flags -> flags{configStripExes = v})+          (boolOpt [] [])+       , option+          ""+          ["library-stripping"]+          "strip libraries upon installation to reduce binary sizes"+          configStripLibs+          (\v flags -> flags{configStripLibs = v})+          (boolOpt [] [])+       , option+          ""+          ["configure-option"]+          "Extra option for configure"+          configConfigureArgs+          (\v flags -> flags{configConfigureArgs = v})+          (reqArg' "OPT" (\x -> [x]) id)+       , option+          ""+          ["user-install"]+          "doing a per-user installation"+          configUserInstall+          (\v flags -> flags{configUserInstall = v})+          (boolOpt' ([], ["user"]) ([], ["global"]))+       , option+          ""+          ["package-db"]+          ( "Append the given package database to the list of package"+              ++ " databases used (to satisfy dependencies and register into)."+              ++ " May be a specific file, 'global' or 'user'. The initial list"+              ++ " is ['global'], ['global', 'user'], or ['global', $sandbox],"+              ++ " depending on context. Use 'clear' to reset the list to empty."+              ++ " See the user guide for details."+          )+          configPackageDBs+          (\v flags -> flags{configPackageDBs = v})+          (reqArg' "DB" readPackageDbList showPackageDbList)+       , option+          "f"+          ["flags"]+          "Force values for the given flags in Cabal conditionals in the .cabal file.  E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false."+          configConfigurationsFlags+          (\v flags -> flags{configConfigurationsFlags = v})+          ( reqArg+              "FLAGS"+              (parsecToReadE (\err -> "Invalid flag assignment: " ++ err) legacyParsecFlagAssignment)+              legacyShowFlagAssignment'+          )+       , option+          ""+          ["extra-include-dirs"]+          "A list of directories to search for header files"+          configExtraIncludeDirs+          (\v flags -> flags{configExtraIncludeDirs = v})+          (reqArg' "PATH" (\x -> [makeSymbolicPath x]) (fmap getSymbolicPath))+       , option+          ""+          ["deterministic"]+          "Try to be as deterministic as possible (used by the test suite)"+          configDeterministic+          (\v flags -> flags{configDeterministic = v})+          (boolOpt [] [])+       , option+          ""+          ["ipid"]+          "Installed package ID to compile this package as"+          configIPID+          (\v flags -> flags{configIPID = v})+          (reqArgFlag "IPID")+       , option+          ""+          ["cid"]+          "Installed component ID to compile this component as"+          (fmap prettyShow . configCID)+          (\v flags -> flags{configCID = fmap mkComponentId v})+          (reqArgFlag "CID")+       , option+          ""+          ["extra-lib-dirs"]+          "A list of directories to search for external libraries"+          configExtraLibDirs+          (\v flags -> flags{configExtraLibDirs = v})+          (reqArg' "PATH" (\x -> [makeSymbolicPath x]) (fmap getSymbolicPath))+       , option+          ""+          ["extra-lib-dirs-static"]+          "A list of directories to search for external libraries when linking fully static executables"+          configExtraLibDirsStatic+          (\v flags -> flags{configExtraLibDirsStatic = v})+          (reqArg' "PATH" (\x -> [makeSymbolicPath x]) (fmap getSymbolicPath))+       , option+          ""+          ["extra-framework-dirs"]+          "A list of directories to search for external frameworks (OS X only)"+          configExtraFrameworkDirs+          (\v flags -> flags{configExtraFrameworkDirs = v})+          (reqArg' "PATH" (\x -> [makeSymbolicPath x]) (fmap getSymbolicPath))+       , option+          ""+          ["extra-prog-path"]+          "A list of directories to search for required programs (in addition to the normal search locations)"+          configProgramPathExtra+          (\v flags -> flags{configProgramPathExtra = v})+          (reqArg' "PATH" (\x -> toNubList [x]) fromNubList)+       , option+          ""+          ["constraint"]+          "A list of additional constraints on the dependencies."+          configConstraints+          (\v flags -> flags{configConstraints = v})+          ( reqArg+              "DEPENDENCY"+              (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec))+              (map prettyShow)+          )+       , option+          ""+          ["dependency"]+          "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\""+          configDependencies+          (\v flags -> flags{configDependencies = v})+          ( reqArg+              "NAME[:COMPONENT_NAME]=CID"+              (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent))+              (map prettyGivenComponent)+          )+       , option+          ""+          ["promised-dependency"]+          "A list of promised dependencies. E.g., --promised-dependency=\"void-0.5.8=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\""+          configPromisedDependencies+          (\v flags -> flags{configPromisedDependencies = v})+          ( reqArg+              "NAME-VER[:COMPONENT_NAME]=CID"+              (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecPromisedComponent))+              (map prettyPromisedComponent)+          )+       , option+          ""+          ["instantiate-with"]+          "A mapping of signature names to concrete module instantiations."+          configInstantiateWith+          (\v flags -> flags{configInstantiateWith = v})+          ( reqArg+              "NAME=MOD"+              (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (: []) parsecModSubstEntry))+              (map (Disp.renderStyle defaultStyle . dispModSubstEntry))+          )+       , option+          ""+          ["tests"]+          "dependency checking and compilation for test suites listed in the package description file."+          configTests+          (\v flags -> flags{configTests = v})+          (boolOpt [] [])+       , option+          ""+          ["coverage"]+          "build package with Haskell Program Coverage. (GHC only)"+          configCoverage+          (\v flags -> flags{configCoverage = v})+          (boolOpt [] [])+       , option+          ""+          ["library-coverage"]+          "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)"+          configLibCoverage+          (\v flags -> flags{configLibCoverage = v})+          (boolOpt [] [])+       , option+          ""+          ["exact-configuration"]+          "All direct dependencies and flags are provided on the command line."+          configExactConfiguration+          (\v flags -> flags{configExactConfiguration = v})+          trueArg+       , option+          ""+          ["benchmarks"]+          "dependency checking and compilation for benchmarks listed in the package description file."+          configBenchmarks+          (\v flags -> flags{configBenchmarks = v})+          (boolOpt [] [])+       , option+          ""+          ["relocatable"]+          "building a package that is relocatable. (GHC only)"+          configRelocatable+          (\v flags -> flags{configRelocatable = v})+          (boolOpt [] [])+       , option+          ""+          ["response-files"]+          "enable workaround for old versions of programs like \"ar\" that do not support @file arguments"+          configUseResponseFiles+          (\v flags -> flags{configUseResponseFiles = v})+          (boolOpt' ([], ["disable-response-files"]) ([], []))+       , option+          ""+          ["allow-depending-on-private-libs"]+          ( "Allow depending on private libraries. "+              ++ "If set, the library visibility check MUST be done externally."+          )+          configAllowDependingOnPrivateLibs+          (\v flags -> flags{configAllowDependingOnPrivateLibs = v})+          trueArg+       , option+          ""+          ["coverage-for"]+          "A list of unit-ids of libraries to include in the Haskell Program Coverage report."+          configCoverageFor+          ( \v flags ->+              flags+                { configCoverageFor =+                    mergeListFlag (configCoverageFor flags) v+                }+          )+          ( reqArg'+              "UNITID"+              (Flag . (: []) . fromString)+              (fmap prettyShow . fromFlagOrDefault [])+          )+       , option+          ""+          ["ignore-build-tools"]+          ( "Ignore build tool dependencies. "+              ++ "If set, declared build tools needn't be found for compilation to proceed."+          )+          configIgnoreBuildTools+          (\v flags -> flags{configIgnoreBuildTools = v})+          trueArg+       ]+  where+    liftInstallDirs =+      liftOption configInstallDirs (\v flags -> flags{configInstallDirs = v})++    reqPathTemplateArgFlag title _sf _lf d get set =+      reqArgFlag+        title+        _sf+        _lf+        d+        (fmap fromPathTemplate . get)+        (set . fmap toPathTemplate)++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++-- | Show a PackageDB stack entry+--+-- @since 3.7.0.0+showPackageDb :: Maybe PackageDB -> String+showPackageDb Nothing = "clear"+showPackageDb (Just GlobalPackageDB) = "global"+showPackageDb (Just UserPackageDB) = "user"+showPackageDb (Just (SpecificPackageDB db)) = getSymbolicPath db++showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String]+showProfDetailLevelFlag NoFlag = []+showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl]++parsecPromisedComponent :: ParsecParser PromisedComponent+parsecPromisedComponent = do+  pn <- parsec+  ln <- P.option LMainLibName $ do+    _ <- P.char ':'+    ucn <- parsec+    return $+      if unUnqualComponentName ucn == unPackageName (pkgName pn)+        then LMainLibName+        else LSubLibName ucn+  _ <- P.char '='+  cid <- parsec+  return $ PromisedComponent pn ln cid++prettyPromisedComponent :: PromisedComponent -> String+prettyPromisedComponent (PromisedComponent pn cn cid) =+  prettyShow pn+    ++ case cn of+      LMainLibName -> ""+      LSubLibName n -> ":" ++ prettyShow n+    ++ "="+    ++ prettyShow cid++parsecGivenComponent :: ParsecParser GivenComponent+parsecGivenComponent = do+  pn <- parsec+  ln <- P.option LMainLibName $ do+    _ <- P.char ':'+    ucn <- parsec+    return $+      if unUnqualComponentName ucn == unPackageName pn+        then LMainLibName+        else LSubLibName ucn+  _ <- P.char '='+  cid <- parsec+  return $ GivenComponent pn ln cid++prettyGivenComponent :: GivenComponent -> String+prettyGivenComponent (GivenComponent pn cn cid) =+  prettyShow pn+    ++ case cn of+      LMainLibName -> ""+      LSubLibName n -> ":" ++ prettyShow n+    ++ "="+    ++ prettyShow cid++installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))]+installDirsOptions =+  [ option+      ""+      ["prefix"]+      "bake this prefix in preparation of installation"+      prefix+      (\v flags -> flags{prefix = v})+      installDirArg+  , option+      ""+      ["bindir"]+      "installation directory for executables"+      bindir+      (\v flags -> flags{bindir = v})+      installDirArg+  , option+      ""+      ["libdir"]+      "installation directory for libraries"+      libdir+      (\v flags -> flags{libdir = v})+      installDirArg+  , option+      ""+      ["libsubdir"]+      "subdirectory of libdir in which libs are installed"+      libsubdir+      (\v flags -> flags{libsubdir = v})+      installDirArg+  , option+      ""+      ["dynlibdir"]+      "installation directory for dynamic libraries"+      dynlibdir+      (\v flags -> flags{dynlibdir = v})+      installDirArg+  , option+      ""+      ["libexecdir"]+      "installation directory for program executables"+      libexecdir+      (\v flags -> flags{libexecdir = v})+      installDirArg+  , option+      ""+      ["libexecsubdir"]+      "subdirectory of libexecdir in which private executables are installed"+      libexecsubdir+      (\v flags -> flags{libexecsubdir = v})+      installDirArg+  , option+      ""+      ["datadir"]+      "installation directory for read-only data"+      datadir+      (\v flags -> flags{datadir = v})+      installDirArg+  , option+      ""+      ["datasubdir"]+      "subdirectory of datadir in which data files are installed"+      datasubdir+      (\v flags -> flags{datasubdir = v})+      installDirArg+  , option+      ""+      ["docdir"]+      "installation directory for documentation"+      docdir+      (\v flags -> flags{docdir = v})+      installDirArg+  , option+      ""+      ["htmldir"]+      "installation directory for HTML documentation"+      htmldir+      (\v flags -> flags{htmldir = v})+      installDirArg+  , option+      ""+      ["haddockdir"]+      "installation directory for haddock interfaces"+      haddockdir+      (\v flags -> flags{haddockdir = v})+      installDirArg+  , option+      ""+      ["sysconfdir"]+      "installation directory for configuration files"+      sysconfdir+      (\v flags -> flags{sysconfdir = v})+      installDirArg+  ]+  where+    installDirArg _sf _lf d get set =+      reqArgFlag+        "DIR"+        _sf+        _lf+        d+        (fmap fromPathTemplate . get)+        (set . fmap toPathTemplate)++emptyConfigFlags :: ConfigFlags+emptyConfigFlags = mempty++instance Monoid ConfigFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ConfigFlags where+  (<>) = gmappend++-- | Arguments to pass to a @configure@ script, e.g. generated by+-- @autoconf@.+configureArgs :: Bool -> ConfigFlags -> [String]+configureArgs bcHack flags =+  hc_flag+    ++ optFlag "with-hc-pkg" configHcPkg+    ++ optFlag' "prefix" prefix+    ++ optFlag' "bindir" bindir+    ++ optFlag' "libdir" libdir+    ++ optFlag' "libexecdir" libexecdir+    ++ optFlag' "datadir" datadir+    ++ optFlag' "sysconfdir" sysconfdir+    ++ configConfigureArgs flags+  where+    hc_flag = case (configHcFlavor flags, configHcPath flags) of+      (_, Flag hc_path) -> [hc_flag_name ++ hc_path]+      (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc]+      (NoFlag, NoFlag) -> []+    hc_flag_name+      -- TODO kill off this bc hack when defaultUserHooks is removed.+      | bcHack = "--with-hc="+      | otherwise = "--with-compiler="+    optFlag name config_field = case config_field flags of+      Flag p -> ["--" ++ name ++ "=" ++ p]+      NoFlag -> []+    optFlag' name config_field =+      optFlag+        name+        ( fmap fromPathTemplate+            . config_field+            . configInstallDirs+        )
+ src/Distribution/Simple/Setup/Copy.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :  Distribution.Simple.Setup.Copy+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Definition of the copy command-line options.+-- See: @Distribution.Simple.Setup@+module Distribution.Simple.Setup.Copy+  ( CopyFlags+      ( CopyCommonFlags+      , copyVerbosity+      , copyDistPref+      , copyCabalFilePath+      , copyWorkingDir+      , copyTargets+      , ..+      )+  , emptyCopyFlags+  , defaultCopyFlags+  , copyCommand+  ) where++import Distribution.Compat.Prelude hiding (get)+import Prelude ()++import Distribution.ReadE+import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import Distribution.Simple.Flag+import Distribution.Simple.InstallDirs+import Distribution.Simple.Setup.Common+import Distribution.Simple.Utils+import Distribution.Utils.Path+import Distribution.Verbosity++-- ------------------------------------------------------------++-- * Copy flags++-- ------------------------------------------------------------++-- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity)+data CopyFlags = CopyFlags+  { copyCommonFlags :: !CommonSetupFlags+  , copyDest :: Flag CopyDest+  }+  deriving (Show, Generic)++pattern CopyCommonFlags+  :: Flag Verbosity+  -> Flag (SymbolicPath Pkg (Dir Dist))+  -> Flag (SymbolicPath CWD (Dir Pkg))+  -> Flag (SymbolicPath Pkg File)+  -> [String]+  -> CopyFlags+pattern CopyCommonFlags+  { copyVerbosity+  , copyDistPref+  , copyWorkingDir+  , copyCabalFilePath+  , copyTargets+  } <-+  ( copyCommonFlags ->+      CommonSetupFlags+        { setupVerbosity = copyVerbosity+        , setupDistPref = copyDistPref+        , setupWorkingDir = copyWorkingDir+        , setupCabalFilePath = copyCabalFilePath+        , setupTargets = copyTargets+        }+    )++instance Binary CopyFlags+instance Structured CopyFlags++defaultCopyFlags :: CopyFlags+defaultCopyFlags =+  CopyFlags+    { copyCommonFlags = defaultCommonSetupFlags+    , copyDest = Flag NoCopyDest+    }++copyCommand :: CommandUI CopyFlags+copyCommand =+  CommandUI+    { commandName = "copy"+    , commandSynopsis = "Copy the files of all/specific components to install locations."+    , commandDescription = Just $ \_ ->+        wrapText $+          "Components encompass executables and libraries. "+            ++ "Does not call register, and allows a prefix at install time. "+            ++ "Without the --destdir flag, configure determines location.\n"+    , commandNotes = Just $ \pname ->+        "Examples:\n"+          ++ "  "+          ++ pname+          ++ " copy           "+          ++ "    All the components in the package\n"+          ++ "  "+          ++ pname+          ++ " copy foo       "+          ++ "    A component (i.e. lib, exe, test suite)"+    , commandUsage =+        usageAlternatives "copy" $+          [ "[FLAGS]"+          , "COMPONENTS [FLAGS]"+          ]+    , commandDefaultFlags = defaultCopyFlags+    , commandOptions = \showOrParseArgs -> case showOrParseArgs of+        ShowArgs ->+          filter+            ( (`notElem` ["target-package-db"])+                . optionName+            )+            $ copyOptions ShowArgs+        ParseArgs -> copyOptions ParseArgs+    }++copyOptions :: ShowOrParseArgs -> [OptionField CopyFlags]+copyOptions showOrParseArgs =+  withCommonSetupOptions+    copyCommonFlags+    (\c f -> f{copyCommonFlags = c})+    showOrParseArgs+    [ option+        ""+        ["destdir"]+        "directory to copy files to, prepended to installation directories"+        copyDest+        ( \v flags -> case copyDest flags of+            Flag (CopyToDb _) -> error "Use either 'destdir' or 'target-package-db'."+            _ -> flags{copyDest = v}+        )+        ( reqArg+            "DIR"+            (succeedReadE (Flag . CopyTo))+            (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])+        )+    , option+        ""+        ["target-package-db"]+        "package database to copy files into. Required when using ${pkgroot} prefix."+        copyDest+        ( \v flags -> case copyDest flags of+            NoFlag -> flags{copyDest = v}+            Flag NoCopyDest -> flags{copyDest = v}+            _ -> error "Use either 'destdir' or 'target-package-db'."+        )+        ( reqArg+            "DATABASE"+            (succeedReadE (Flag . CopyToDb))+            (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])+        )+    ]++emptyCopyFlags :: CopyFlags+emptyCopyFlags = mempty++instance Monoid CopyFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup CopyFlags where+  (<>) = gmappend
+ src/Distribution/Simple/Setup/Global.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module      :  Distribution.Simple.Setup.Global+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Definition of the global command-line options.+-- See: @Distribution.Simple.Setup@+module Distribution.Simple.Setup.Global+  ( GlobalFlags (..)+  , emptyGlobalFlags+  , defaultGlobalFlags+  , globalCommand+  ) where++import Distribution.Compat.Prelude hiding (get)+import Prelude ()++import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import Distribution.Simple.Flag+import Distribution.Simple.Setup.Common+import Distribution.Utils.Path++-- ------------------------------------------------------------++-- * Global flags++-- ------------------------------------------------------------++-- In fact since individual flags types are monoids and these are just sets of+-- flags then they are also monoids pointwise. This turns out to be really+-- useful. The mempty is the set of empty flags and mappend allows us to+-- override specific flags. For example we can start with default flags and+-- override with the ones we get from a file or the command line, or both.++-- | Flags that apply at the top level, not to any sub-command.+data GlobalFlags = GlobalFlags+  { globalVersion :: Flag Bool+  , globalNumericVersion :: Flag Bool+  , globalWorkingDir :: Flag (SymbolicPath CWD (Dir Pkg))+  }+  deriving (Generic)++defaultGlobalFlags :: GlobalFlags+defaultGlobalFlags =+  GlobalFlags+    { globalVersion = Flag False+    , globalNumericVersion = Flag False+    , globalWorkingDir = NoFlag+    }++globalCommand :: [Command action] -> CommandUI GlobalFlags+globalCommand commands =+  CommandUI+    { commandName = ""+    , commandSynopsis = ""+    , commandUsage = \pname ->+        "This Setup program uses the Haskell Cabal Infrastructure.\n"+          ++ "See http://www.haskell.org/cabal/ for more information.\n"+          ++ "\n"+          ++ "Usage: "+          ++ pname+          ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n"+    , commandDescription = Just $ \pname ->+        let+          commands' = commands ++ [commandAddAction helpCommandUI undefined]+          cmdDescs = getNormalCommandDescriptions commands'+          maxlen = maximum $ [length name | (name, _) <- cmdDescs]+          align str = str ++ replicate (maxlen - length str) ' '+         in+          "Commands:\n"+            ++ unlines+              [ "  " ++ align name ++ "    " ++ descr+              | (name, descr) <- cmdDescs+              ]+            ++ "\n"+            ++ "For more information about a command use\n"+            ++ "  "+            ++ pname+            ++ " COMMAND --help\n\n"+            ++ "Typical steps for installing Cabal packages:\n"+            ++ concat+              [ "  " ++ pname ++ " " ++ x ++ "\n"+              | x <- ["configure", "build", "install"]+              ]+    , commandNotes = Nothing+    , commandDefaultFlags = defaultGlobalFlags+    , commandOptions = \_ ->+        [ option+            ['V']+            ["version"]+            "Print version information"+            globalVersion+            (\v flags -> flags{globalVersion = v})+            trueArg+        , option+            []+            ["numeric-version"]+            "Print just the version number"+            globalNumericVersion+            (\v flags -> flags{globalNumericVersion = v})+            trueArg+        , option+            ""+            ["working-dir"]+            "Set working directory"+            globalWorkingDir+            (\v flags -> flags{globalWorkingDir = v})+            (reqSymbolicPathArgFlag "DIR")+        ]+    }++emptyGlobalFlags :: GlobalFlags+emptyGlobalFlags = mempty++instance Monoid GlobalFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup GlobalFlags where+  (<>) = gmappend
+ src/Distribution/Simple/Setup/Haddock.hs view
@@ -0,0 +1,642 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :  Distribution.Simple.Setup.Haddock+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Definition of the haddock command-line options.+-- See: @Distribution.Simple.Setup@+module Distribution.Simple.Setup.Haddock+  ( HaddockTarget (..)+  , HaddockFlags+    ( HaddockCommonFlags+    , haddockVerbosity+    , haddockDistPref+    , haddockCabalFilePath+    , haddockWorkingDir+    , haddockTargets+    , ..+    )+  , emptyHaddockFlags+  , defaultHaddockFlags+  , haddockCommand+  , Visibility (..)+  , HaddockProjectFlags (..)+  , emptyHaddockProjectFlags+  , defaultHaddockProjectFlags+  , haddockProjectCommand+  , haddockOptions+  , haddockProjectOptions+  ) where++import Distribution.Compat.Prelude hiding (get)+import Prelude ()++import qualified Distribution.Compat.CharParsing as P+import Distribution.Parsec+import Distribution.Pretty+import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import Distribution.Simple.Flag+import Distribution.Simple.InstallDirs+import Distribution.Simple.Program+import Distribution.Simple.Setup.Common+import Distribution.Utils.Path+import Distribution.Verbosity++import qualified Text.PrettyPrint as Disp++-- ------------------------------------------------------------++-- * Haddock flags++-- ------------------------------------------------------------++-- | When we build haddock documentation, there are two cases:+--+-- 1. We build haddocks only for the current development version,+--    intended for local use and not for distribution. In this case,+--    we store the generated documentation in @<dist>/doc/html/<package name>@.+--+-- 2. We build haddocks for intended for uploading them to hackage.+--    In this case, we need to follow the layout that hackage expects+--    from documentation tarballs, and we might also want to use different+--    flags than for development builds, so in this case we store the generated+--    documentation in @<dist>/doc/html/<package id>-docs@.+data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic)++instance Binary HaddockTarget+instance Structured HaddockTarget++instance Pretty HaddockTarget where+  pretty ForHackage = Disp.text "for-hackage"+  pretty ForDevelopment = Disp.text "for-development"++instance Parsec HaddockTarget where+  parsec =+    P.choice+      [ P.try $ P.string "for-hackage" >> return ForHackage+      , P.string "for-development" >> return ForDevelopment+      ]++data HaddockFlags = HaddockFlags+  { haddockCommonFlags :: !CommonSetupFlags+  , haddockProgramPaths :: [(String, FilePath)]+  , haddockProgramArgs :: [(String, [String])]+  , haddockHoogle :: Flag Bool+  , haddockHtml :: Flag Bool+  , haddockHtmlLocation :: Flag String+  , haddockForHackage :: Flag HaddockTarget+  , haddockExecutables :: Flag Bool+  , haddockTestSuites :: Flag Bool+  , haddockBenchmarks :: Flag Bool+  , haddockForeignLibs :: Flag Bool+  , haddockInternal :: Flag Bool+  , haddockCss :: Flag FilePath+  , haddockLinkedSource :: Flag Bool+  , haddockQuickJump :: Flag Bool+  , haddockHscolourCss :: Flag FilePath+  , haddockContents :: Flag PathTemplate+  , haddockIndex :: Flag PathTemplate+  , haddockBaseUrl :: Flag String+  , haddockResourcesDir :: Flag String+  , haddockOutputDir :: Flag FilePath+  , haddockUseUnicode :: Flag Bool+  }+  deriving (Show, Generic)++pattern HaddockCommonFlags+  :: Flag Verbosity+  -> Flag (SymbolicPath Pkg (Dir Dist))+  -> Flag (SymbolicPath CWD (Dir Pkg))+  -> Flag (SymbolicPath Pkg File)+  -> [String]+  -> HaddockFlags+pattern HaddockCommonFlags+  { haddockVerbosity+  , haddockDistPref+  , haddockWorkingDir+  , haddockCabalFilePath+  , haddockTargets+  } <-+  ( haddockCommonFlags ->+      CommonSetupFlags+        { setupVerbosity = haddockVerbosity+        , setupDistPref = haddockDistPref+        , setupWorkingDir = haddockWorkingDir+        , setupCabalFilePath = haddockCabalFilePath+        , setupTargets = haddockTargets+        }+    )++instance Binary HaddockFlags+instance Structured HaddockFlags++defaultHaddockFlags :: HaddockFlags+defaultHaddockFlags =+  HaddockFlags+    { haddockCommonFlags = defaultCommonSetupFlags+    , haddockProgramPaths = mempty+    , haddockProgramArgs = []+    , haddockHoogle = Flag False+    , haddockHtml = Flag False+    , haddockHtmlLocation = NoFlag+    , haddockForHackage = NoFlag+    , haddockExecutables = Flag False+    , haddockTestSuites = Flag False+    , haddockBenchmarks = Flag False+    , haddockForeignLibs = Flag False+    , haddockInternal = Flag False+    , haddockCss = NoFlag+    , haddockLinkedSource = Flag False+    , haddockQuickJump = Flag False+    , haddockHscolourCss = NoFlag+    , haddockContents = NoFlag+    , haddockIndex = NoFlag+    , haddockBaseUrl = NoFlag+    , haddockResourcesDir = NoFlag+    , haddockOutputDir = NoFlag+    , haddockUseUnicode = Flag False+    }++haddockCommand :: CommandUI HaddockFlags+haddockCommand =+  CommandUI+    { commandName = "haddock"+    , commandSynopsis = "Generate Haddock HTML documentation."+    , commandDescription = Just $ \_ ->+        "Requires the program haddock, version 2.x.\n"+    , commandNotes = Nothing+    , commandUsage =+        usageAlternatives "haddock" $+          [ "[FLAGS]"+          , "COMPONENTS [FLAGS]"+          ]+    , commandDefaultFlags = defaultHaddockFlags+    , commandOptions = \showOrParseArgs ->+        haddockOptions showOrParseArgs+          ++ programDbPaths+            progDb+            ParseArgs+            haddockProgramPaths+            (\v flags -> flags{haddockProgramPaths = v})+          ++ programDbOption+            progDb+            showOrParseArgs+            haddockProgramArgs+            (\v fs -> fs{haddockProgramArgs = v})+          ++ programDbOptions+            progDb+            ParseArgs+            haddockProgramArgs+            (\v flags -> flags{haddockProgramArgs = v})+    }+  where+    progDb =+      addKnownProgram haddockProgram $+        addKnownProgram ghcProgram $+          emptyProgramDb++haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags]+haddockOptions showOrParseArgs =+  withCommonSetupOptions+    haddockCommonFlags+    (\c f -> f{haddockCommonFlags = c})+    showOrParseArgs+    [ option+        ""+        ["hoogle"]+        "Generate a hoogle database"+        haddockHoogle+        (\v flags -> flags{haddockHoogle = v})+        trueArg+    , option+        ""+        ["html"]+        "Generate HTML documentation (the default)"+        haddockHtml+        (\v flags -> flags{haddockHtml = v})+        trueArg+    , option+        ""+        ["html-location"]+        "Location of HTML documentation for pre-requisite packages"+        haddockHtmlLocation+        (\v flags -> flags{haddockHtmlLocation = v})+        (reqArgFlag "URL")+    , option+        ""+        ["for-hackage"]+        "Collection of flags to generate documentation suitable for upload to hackage"+        haddockForHackage+        (\v flags -> flags{haddockForHackage = v})+        (noArg (Flag ForHackage))+    , option+        ""+        ["executables"]+        "Run haddock for Executables targets"+        haddockExecutables+        (\v flags -> flags{haddockExecutables = v})+        trueArg+    , option+        ""+        ["tests"]+        "Run haddock for Test Suite targets"+        haddockTestSuites+        (\v flags -> flags{haddockTestSuites = v})+        trueArg+    , option+        ""+        ["benchmarks"]+        "Run haddock for Benchmark targets"+        haddockBenchmarks+        (\v flags -> flags{haddockBenchmarks = v})+        trueArg+    , option+        ""+        ["foreign-libraries"]+        "Run haddock for Foreign Library targets"+        haddockForeignLibs+        (\v flags -> flags{haddockForeignLibs = v})+        trueArg+    , option+        ""+        ["all"]+        "Run haddock for all targets"+        ( \f ->+            allFlags+              [ haddockExecutables f+              , haddockTestSuites f+              , haddockBenchmarks f+              , haddockForeignLibs f+              ]+        )+        ( \v flags ->+            flags+              { haddockExecutables = v+              , haddockTestSuites = v+              , haddockBenchmarks = v+              , haddockForeignLibs = v+              }+        )+        trueArg+    , option+        ""+        ["internal"]+        "Run haddock for internal modules and include all symbols"+        haddockInternal+        (\v flags -> flags{haddockInternal = v})+        trueArg+    , option+        ""+        ["css"]+        "Use PATH as the haddock stylesheet"+        haddockCss+        (\v flags -> flags{haddockCss = v})+        (reqArgFlag "PATH")+    , option+        ""+        ["hyperlink-source", "hyperlink-sources", "hyperlinked-source"]+        "Hyperlink the documentation to the source code"+        haddockLinkedSource+        (\v flags -> flags{haddockLinkedSource = v})+        trueArg+    , option+        ""+        ["quickjump"]+        "Generate an index for interactive documentation navigation"+        haddockQuickJump+        (\v flags -> flags{haddockQuickJump = v})+        trueArg+    , option+        ""+        ["hscolour-css"]+        "Use PATH as the HsColour stylesheet"+        haddockHscolourCss+        (\v flags -> flags{haddockHscolourCss = v})+        (reqArgFlag "PATH")+    , option+        ""+        ["contents-location"]+        "Bake URL in as the location for the contents page"+        haddockContents+        (\v flags -> flags{haddockContents = v})+        ( reqArg'+            "URL"+            (toFlag . toPathTemplate)+            (flagToList . fmap fromPathTemplate)+        )+    , option+        ""+        ["index-location"]+        "Use a separately-generated HTML index"+        haddockIndex+        (\v flags -> flags{haddockIndex = v})+        ( reqArg'+            "URL"+            (toFlag . toPathTemplate)+            (flagToList . fmap fromPathTemplate)+        )+    , option+        ""+        ["base-url"]+        "Base URL for static files."+        haddockBaseUrl+        (\v flags -> flags{haddockBaseUrl = v})+        (reqArgFlag "URL")+    , option+        ""+        ["resources-dir"]+        "location of Haddocks static / auxiliary files"+        haddockResourcesDir+        (\v flags -> flags{haddockResourcesDir = v})+        (reqArgFlag "DIR")+    , option+        ""+        ["output-dir"]+        "Generate haddock documentation into this directory. This flag is provided as a technology preview and is subject to change in the next releases."+        haddockOutputDir+        (\v flags -> flags{haddockOutputDir = v})+        (reqArgFlag "DIR")+    , option+        ""+        ["use-unicode"]+        "Pass --use-unicode option to haddock"+        haddockUseUnicode+        (\v flags -> flags{haddockUseUnicode = v})+        trueArg+    ]++emptyHaddockFlags :: HaddockFlags+emptyHaddockFlags = mempty++instance Monoid HaddockFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup HaddockFlags where+  (<>) = gmappend++-- ------------------------------------------------------------++-- * HaddocksFlags flags++-- ------------------------------------------------------------++-- | Governs whether modules from a given interface should be visible or+-- hidden in the Haddock generated content page.  We don't expose this+-- functionality to the user, but simply use 'Visible' for only local packages.+-- Visibility of modules is available since @haddock-2.26.1@.+data Visibility = Visible | Hidden+  deriving (Eq, Show)++data HaddockProjectFlags = HaddockProjectFlags+  { 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`+  -- * `--gen-index`+  -- * `--gen-contents`+  -- * `--hyperlinked-source`+  , -- options passed to @haddock@ via 'createHaddockIndex'+    haddockProjectDir :: Flag String+  -- ^ output directory of combined haddocks, the default is './haddocks'+  , haddockProjectPrologue :: Flag String+  , haddockProjectInterfaces :: Flag [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]+  -- ^ 'haddocksInterfaces' is inferred by the 'haddocksAction'; currently not+  -- exposed to the user.+  , -- options passed to @haddock@ via 'HaddockFlags' when building+    -- documentation++    haddockProjectProgramPaths :: [(String, FilePath)]+  , haddockProjectProgramArgs :: [(String, [String])]+  , haddockProjectHoogle :: Flag Bool+  , -- haddockHtml is not supported+    haddockProjectHtmlLocation :: Flag String+  , -- haddockForHackage is not supported+    haddockProjectExecutables :: Flag Bool+  , haddockProjectTestSuites :: Flag Bool+  , haddockProjectBenchmarks :: Flag Bool+  , haddockProjectForeignLibs :: Flag Bool+  , haddockProjectInternal :: Flag Bool+  , haddockProjectCss :: Flag FilePath+  , haddockProjectHscolourCss :: Flag FilePath+  , -- haddockContent is not supported, a fixed value is provided+    -- haddockIndex is not supported, a fixed value is provided+    -- haddockDistPerf is not supported, note: it changes location of the haddocks+    -- haddockBaseUrl is not supported, a fixed value is provided+    haddockProjectResourcesDir :: Flag String+  , haddockProjectUseUnicode :: Flag Bool+  }+  deriving (Show, Generic)++defaultHaddockProjectFlags :: HaddockProjectFlags+defaultHaddockProjectFlags =+  HaddockProjectFlags+    { haddockProjectCommonFlags = defaultCommonSetupFlags+    , haddockProjectHackage = Flag False+    , haddockProjectDir = Flag "./haddocks"+    , haddockProjectPrologue = NoFlag+    , haddockProjectTestSuites = Flag False+    , haddockProjectProgramPaths = mempty+    , haddockProjectProgramArgs = mempty+    , haddockProjectHoogle = Flag False+    , haddockProjectHtmlLocation = NoFlag+    , haddockProjectExecutables = Flag False+    , haddockProjectBenchmarks = Flag False+    , haddockProjectForeignLibs = Flag False+    , haddockProjectInternal = Flag False+    , haddockProjectCss = NoFlag+    , haddockProjectHscolourCss = NoFlag+    , haddockProjectResourcesDir = NoFlag+    , haddockProjectInterfaces = NoFlag+    , haddockProjectUseUnicode = NoFlag+    }++haddockProjectCommand :: CommandUI HaddockProjectFlags+haddockProjectCommand =+  CommandUI+    { commandName = "v2-haddock-project"+    , commandSynopsis = "Generate Haddocks HTML documentation for the cabal project."+    , commandDescription = Just $ \_ ->+        "Requires the program haddock, version 2.26.\n"+    , commandNotes = Nothing+    , commandUsage =+        usageAlternatives "haddock-project" $+          [ "[FLAGS]"+          , "COMPONENTS [FLAGS]"+          ]+    , commandDefaultFlags = defaultHaddockProjectFlags+    , commandOptions = \showOrParseArgs ->+        haddockProjectOptions showOrParseArgs+          ++ programDbPaths+            progDb+            ParseArgs+            haddockProjectProgramPaths+            (\v flags -> flags{haddockProjectProgramPaths = v})+          ++ programDbOption+            progDb+            showOrParseArgs+            haddockProjectProgramArgs+            (\v fs -> fs{haddockProjectProgramArgs = v})+          ++ programDbOptions+            progDb+            ParseArgs+            haddockProjectProgramArgs+            (\v flags -> flags{haddockProjectProgramArgs = v})+    }+  where+    progDb =+      addKnownProgram haddockProgram $+        addKnownProgram ghcProgram $+          emptyProgramDb++haddockProjectOptions :: ShowOrParseArgs -> [OptionField HaddockProjectFlags]+haddockProjectOptions showOrParseArgs =+  withCommonSetupOptions+    haddockProjectCommonFlags+    (\c f -> f{haddockProjectCommonFlags = c})+    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+        ""+        ["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++instance Monoid HaddockProjectFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup HaddockProjectFlags where+  (<>) = gmappend
+ src/Distribution/Simple/Setup/Hscolour.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :  Distribution.Simple.Setup.Hscolour+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Definition of the hscolour command-line options.+-- See: @Distribution.Simple.Setup@+module Distribution.Simple.Setup.Hscolour+  ( HscolourFlags+      ( HscolourCommonFlags+      , hscolourVerbosity+      , hscolourDistPref+      , hscolourCabalFilePath+      , hscolourWorkingDir+      , hscolourTargets+      , ..+      )+  , emptyHscolourFlags+  , defaultHscolourFlags+  , hscolourCommand+  ) where++import Distribution.Compat.Prelude hiding (get)+import Prelude ()++import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import Distribution.Simple.Flag+import Distribution.Simple.Setup.Common+import Distribution.Utils.Path+import Distribution.Verbosity++-- ------------------------------------------------------------++-- * HsColour flags++-- ------------------------------------------------------------++data HscolourFlags = HscolourFlags+  { hscolourCommonFlags :: !CommonSetupFlags+  , hscolourCSS :: Flag FilePath+  , hscolourExecutables :: Flag Bool+  , hscolourTestSuites :: Flag Bool+  , hscolourBenchmarks :: Flag Bool+  , hscolourForeignLibs :: Flag Bool+  }+  deriving (Show, Generic)++pattern HscolourCommonFlags+  :: Flag Verbosity+  -> Flag (SymbolicPath Pkg (Dir Dist))+  -> Flag (SymbolicPath CWD (Dir Pkg))+  -> Flag (SymbolicPath Pkg File)+  -> [String]+  -> HscolourFlags+pattern HscolourCommonFlags+  { hscolourVerbosity+  , hscolourDistPref+  , hscolourWorkingDir+  , hscolourCabalFilePath+  , hscolourTargets+  } <-+  ( hscolourCommonFlags ->+      CommonSetupFlags+        { setupVerbosity = hscolourVerbosity+        , setupDistPref = hscolourDistPref+        , setupWorkingDir = hscolourWorkingDir+        , setupCabalFilePath = hscolourCabalFilePath+        , setupTargets = hscolourTargets+        }+    )++instance Binary HscolourFlags+instance Structured HscolourFlags++emptyHscolourFlags :: HscolourFlags+emptyHscolourFlags = mempty++defaultHscolourFlags :: HscolourFlags+defaultHscolourFlags =+  HscolourFlags+    { hscolourCommonFlags = defaultCommonSetupFlags+    , hscolourCSS = NoFlag+    , hscolourExecutables = Flag False+    , hscolourTestSuites = Flag False+    , hscolourBenchmarks = Flag False+    , hscolourForeignLibs = Flag False+    }++instance Monoid HscolourFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup HscolourFlags where+  (<>) = gmappend++hscolourCommand :: CommandUI HscolourFlags+hscolourCommand =+  CommandUI+    { commandName = "hscolour"+    , commandSynopsis =+        "Generate HsColour colourised code, in HTML format."+    , commandDescription = Just (\_ -> "Requires the hscolour program.\n")+    , commandNotes = Just $ \_ ->+        "Deprecated in favour of 'cabal haddock --hyperlink-source'."+    , commandUsage = \pname ->+        "Usage: " ++ pname ++ " hscolour [FLAGS]\n"+    , commandDefaultFlags = defaultHscolourFlags+    , commandOptions = \showOrParseArgs ->+        withCommonSetupOptions+          hscolourCommonFlags+          (\c f -> f{hscolourCommonFlags = c})+          showOrParseArgs+          [ option+              ""+              ["executables"]+              "Run hscolour for Executables targets"+              hscolourExecutables+              (\v flags -> flags{hscolourExecutables = v})+              trueArg+          , option+              ""+              ["tests"]+              "Run hscolour for Test Suite targets"+              hscolourTestSuites+              (\v flags -> flags{hscolourTestSuites = v})+              trueArg+          , option+              ""+              ["benchmarks"]+              "Run hscolour for Benchmark targets"+              hscolourBenchmarks+              (\v flags -> flags{hscolourBenchmarks = v})+              trueArg+          , option+              ""+              ["foreign-libraries"]+              "Run hscolour for Foreign Library targets"+              hscolourForeignLibs+              (\v flags -> flags{hscolourForeignLibs = v})+              trueArg+          , option+              ""+              ["all"]+              "Run hscolour for all targets"+              ( \f ->+                  allFlags+                    [ hscolourExecutables f+                    , hscolourTestSuites f+                    , hscolourBenchmarks f+                    , hscolourForeignLibs f+                    ]+              )+              ( \v flags ->+                  flags+                    { hscolourExecutables = v+                    , hscolourTestSuites = v+                    , hscolourBenchmarks = v+                    , hscolourForeignLibs = v+                    }+              )+              trueArg+          , option+              ""+              ["css"]+              "Use a cascading style sheet"+              hscolourCSS+              (\v flags -> flags{hscolourCSS = v})+              (reqArgFlag "PATH")+          ]+    }
+ src/Distribution/Simple/Setup/Install.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :  Distribution.Simple.Setup.Install+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Definition of the install command-line options.+-- See: @Distribution.Simple.Setup@+module Distribution.Simple.Setup.Install+  ( InstallFlags+      ( InstallCommonFlags+      , installVerbosity+      , installDistPref+      , installCabalFilePath+      , installWorkingDir+      , installTargets+      , ..+      )+  , emptyInstallFlags+  , defaultInstallFlags+  , installCommand+  ) where++import Distribution.Compat.Prelude hiding (get)+import Prelude ()++import Distribution.ReadE+import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import Distribution.Simple.Compiler+import Distribution.Simple.Flag+import Distribution.Simple.InstallDirs+import Distribution.Simple.Setup.Common+import Distribution.Simple.Utils+import Distribution.Utils.Path+import Distribution.Verbosity++-- ------------------------------------------------------------++-- * Install flags++-- ------------------------------------------------------------++-- | Flags to @install@: (package db, verbosity)+data InstallFlags = InstallFlags+  { installCommonFlags :: !CommonSetupFlags+  , installPackageDB :: Flag PackageDB+  , installDest :: Flag CopyDest+  , installUseWrapper :: Flag Bool+  , installInPlace :: Flag Bool+  }+  deriving (Show, Generic)++pattern InstallCommonFlags+  :: Flag Verbosity+  -> Flag (SymbolicPath Pkg (Dir Dist))+  -> Flag (SymbolicPath CWD (Dir Pkg))+  -> Flag (SymbolicPath Pkg File)+  -> [String]+  -> InstallFlags+pattern InstallCommonFlags+  { installVerbosity+  , installDistPref+  , installWorkingDir+  , installCabalFilePath+  , installTargets+  } <-+  ( installCommonFlags ->+      CommonSetupFlags+        { setupVerbosity = installVerbosity+        , setupDistPref = installDistPref+        , setupWorkingDir = installWorkingDir+        , setupCabalFilePath = installCabalFilePath+        , setupTargets = installTargets+        }+    )++defaultInstallFlags :: InstallFlags+defaultInstallFlags =+  InstallFlags+    { installCommonFlags = defaultCommonSetupFlags+    , installPackageDB = NoFlag+    , installDest = Flag NoCopyDest+    , installUseWrapper = Flag False+    , installInPlace = Flag False+    }++installCommand :: CommandUI InstallFlags+installCommand =+  CommandUI+    { commandName = "install"+    , commandSynopsis =+        "Copy the files into the install locations. Run register."+    , commandDescription = Just $ \_ ->+        wrapText $+          "Unlike the copy command, install calls the register command. "+            ++ "If you want to install into a location that is not what was "+            ++ "specified in the configure step, use the copy command.\n"+    , commandNotes = Nothing+    , commandUsage = \pname ->+        "Usage: " ++ pname ++ " install [FLAGS]\n"+    , commandDefaultFlags = defaultInstallFlags+    , commandOptions = \showOrParseArgs ->+        withCommonSetupOptions+          installCommonFlags+          (\c f -> f{installCommonFlags = c})+          showOrParseArgs+          $ case showOrParseArgs of+            ShowArgs ->+              filter+                ( (`notElem` ["target-package-db"])+                    . optionName+                )+                installOptions+            ParseArgs -> installOptions+    }++installOptions :: [OptionField InstallFlags]+installOptions =+  [ option+      ""+      ["inplace"]+      "install the package in the install subdirectory of the dist prefix, so it can be used without being installed"+      installInPlace+      (\v flags -> flags{installInPlace = v})+      trueArg+  , option+      ""+      ["shell-wrappers"]+      "using shell script wrappers around executables"+      installUseWrapper+      (\v flags -> flags{installUseWrapper = v})+      (boolOpt [] [])+  , option+      ""+      ["package-db"]+      ""+      installPackageDB+      (\v flags -> flags{installPackageDB = v})+      ( choiceOpt+          [+            ( Flag UserPackageDB+            , ([], ["user"])+            , "upon configuration register this package in the user's local package database"+            )+          ,+            ( Flag GlobalPackageDB+            , ([], ["global"])+            , "(default) upon configuration register this package in the system-wide package database"+            )+          ]+      )+  , option+      ""+      ["target-package-db"]+      "package database to install into. Required when using ${pkgroot} prefix."+      installDest+      (\v flags -> flags{installDest = v})+      ( reqArg+          "DATABASE"+          (succeedReadE (Flag . CopyToDb))+          (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])+      )+  ]++emptyInstallFlags :: InstallFlags+emptyInstallFlags = mempty++instance Monoid InstallFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup InstallFlags where+  (<>) = gmappend
+ src/Distribution/Simple/Setup/Register.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :  Distribution.Simple.Setup.Register+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Definition of the register command-line options.+-- See: @Distribution.Simple.Setup@+module Distribution.Simple.Setup.Register+  ( RegisterFlags+      ( RegisterCommonFlags+      , registerVerbosity+      , registerDistPref+      , registerCabalFilePath+      , registerWorkingDir+      , registerTargets+      , ..+      )+  , emptyRegisterFlags+  , defaultRegisterFlags+  , registerCommand+  , unregisterCommand+  ) where++import Distribution.Compat.Prelude hiding (get)+import Prelude ()++import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import Distribution.Simple.Compiler+import Distribution.Simple.Flag+import Distribution.Simple.Setup.Common+import Distribution.Utils.Path+import Distribution.Verbosity++-- ------------------------------------------------------------++-- * Register flags++-- ------------------------------------------------------------++-- | Flags to @register@ and @unregister@: (user package, gen-script,+-- in-place, verbosity)+data RegisterFlags = RegisterFlags+  { registerCommonFlags :: !CommonSetupFlags+  , regPackageDB :: Flag PackageDB+  , regGenScript :: Flag Bool+  , regGenPkgConf :: Flag (Maybe (SymbolicPath Pkg (Dir PkgConf)))+  , regInPlace :: Flag Bool+  , regPrintId :: Flag Bool+  }+  deriving (Show, Generic)++pattern RegisterCommonFlags+  :: Flag Verbosity+  -> Flag (SymbolicPath Pkg (Dir Dist))+  -> Flag (SymbolicPath CWD (Dir Pkg))+  -> Flag (SymbolicPath Pkg File)+  -> [String]+  -> RegisterFlags+pattern RegisterCommonFlags+  { registerVerbosity+  , registerDistPref+  , registerWorkingDir+  , registerCabalFilePath+  , registerTargets+  } <-+  ( registerCommonFlags ->+      CommonSetupFlags+        { setupVerbosity = registerVerbosity+        , setupDistPref = registerDistPref+        , setupWorkingDir = registerWorkingDir+        , setupCabalFilePath = registerCabalFilePath+        , setupTargets = registerTargets+        }+    )++defaultRegisterFlags :: RegisterFlags+defaultRegisterFlags =+  RegisterFlags+    { registerCommonFlags = defaultCommonSetupFlags+    , regPackageDB = NoFlag+    , regGenScript = Flag False+    , regGenPkgConf = NoFlag+    , regInPlace = Flag False+    , regPrintId = Flag False+    }++registerCommand :: CommandUI RegisterFlags+registerCommand =+  CommandUI+    { commandName = "register"+    , commandSynopsis =+        "Register this package with the compiler."+    , commandDescription = Nothing+    , commandNotes = Nothing+    , commandUsage = \pname ->+        "Usage: " ++ pname ++ " register [FLAGS]\n"+    , commandDefaultFlags = defaultRegisterFlags+    , commandOptions = \showOrParseArgs ->+        withCommonSetupOptions+          registerCommonFlags+          (\c f -> f{registerCommonFlags = c})+          showOrParseArgs+          $ [ option+                ""+                ["packageDB"]+                ""+                regPackageDB+                (\v flags -> flags{regPackageDB = v})+                ( choiceOpt+                    [+                      ( Flag UserPackageDB+                      , ([], ["user"])+                      , "upon registration, register this package in the user's local package database"+                      )+                    ,+                      ( Flag GlobalPackageDB+                      , ([], ["global"])+                      , "(default)upon registration, register this package in the system-wide package database"+                      )+                    ]+                )+            , option+                ""+                ["inplace"]+                "register the package in the build location, so it can be used without being installed"+                regInPlace+                (\v flags -> flags{regInPlace = v})+                trueArg+            , option+                ""+                ["gen-script"]+                "instead of registering, generate a script to register later"+                regGenScript+                (\v flags -> flags{regGenScript = v})+                trueArg+            , option+                ""+                ["gen-pkg-config"]+                "instead of registering, generate a package registration file/directory"+                regGenPkgConf+                (\v flags -> flags{regGenPkgConf = v})+                (optArg' "PKG" (Flag . fmap makeSymbolicPath) (flagToList . fmap (fmap getSymbolicPath)))+            , option+                ""+                ["print-ipid"]+                "print the installed package ID calculated for this package"+                regPrintId+                (\v flags -> flags{regPrintId = v})+                trueArg+            ]+    }++unregisterCommand :: CommandUI RegisterFlags+unregisterCommand =+  CommandUI+    { commandName = "unregister"+    , commandSynopsis =+        "Unregister this package with the compiler."+    , commandDescription = Nothing+    , commandNotes = Nothing+    , commandUsage = \pname ->+        "Usage: " ++ pname ++ " unregister [FLAGS]\n"+    , commandDefaultFlags = defaultRegisterFlags+    , commandOptions = \showOrParseArgs ->+        withCommonSetupOptions+          registerCommonFlags+          (\c f -> f{registerCommonFlags = c})+          showOrParseArgs+          $ [ option+                ""+                ["user"]+                ""+                regPackageDB+                (\v flags -> flags{regPackageDB = v})+                ( choiceOpt+                    [+                      ( Flag UserPackageDB+                      , ([], ["user"])+                      , "unregister this package in the user's local package database"+                      )+                    ,+                      ( Flag GlobalPackageDB+                      , ([], ["global"])+                      , "(default) unregister this package in the  system-wide package database"+                      )+                    ]+                )+            , option+                ""+                ["gen-script"]+                "Instead of performing the unregister command, generate a script to unregister later"+                regGenScript+                (\v flags -> flags{regGenScript = v})+                trueArg+            ]+    }++emptyRegisterFlags :: RegisterFlags+emptyRegisterFlags = mempty++instance Monoid RegisterFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup RegisterFlags where+  (<>) = gmappend
+ src/Distribution/Simple/Setup/Repl.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :  Distribution.Simple.Setup.Repl+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Definition of the repl command-line options.+-- See: @Distribution.Simple.Setup@+module Distribution.Simple.Setup.Repl+  ( ReplFlags+      ( ReplCommonFlags+      , replVerbosity+      , replDistPref+      , replCabalFilePath+      , replWorkingDir+      , replTargets+      , ..+      )+  , defaultReplFlags+  , replCommand+  , ReplOptions (..)+  , replOptions+  ) where++import Distribution.Compat.Prelude hiding (get)+import Prelude ()++import Distribution.ReadE+import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import Distribution.Simple.Flag+import Distribution.Simple.Program+import Distribution.Simple.Setup.Common+import Distribution.Simple.Utils+import Distribution.Utils.Path+import Distribution.Verbosity++-- ------------------------------------------------------------++-- * REPL Flags++-- ------------------------------------------------------------++data ReplOptions = ReplOptions+  { replOptionsFlags :: [String]+  , replOptionsNoLoad :: Flag Bool+  , replOptionsFlagOutput :: Flag FilePath+  , replWithRepl :: Flag FilePath+  }+  deriving (Show, Generic)++pattern ReplCommonFlags+  :: Flag Verbosity+  -> Flag (SymbolicPath Pkg (Dir Dist))+  -> Flag (SymbolicPath CWD (Dir Pkg))+  -> Flag (SymbolicPath Pkg File)+  -> [String]+  -> ReplFlags+pattern ReplCommonFlags+  { replVerbosity+  , replDistPref+  , replWorkingDir+  , replCabalFilePath+  , replTargets+  } <-+  ( replCommonFlags ->+      CommonSetupFlags+        { setupVerbosity = replVerbosity+        , setupDistPref = replDistPref+        , setupWorkingDir = replWorkingDir+        , setupCabalFilePath = replCabalFilePath+        , setupTargets = replTargets+        }+    )++instance Binary ReplOptions+instance Structured ReplOptions++instance Monoid ReplOptions where+  mempty = ReplOptions mempty (Flag False) NoFlag NoFlag+  mappend = (<>)++instance Semigroup ReplOptions where+  (<>) = gmappend++data ReplFlags = ReplFlags+  { replCommonFlags :: !CommonSetupFlags+  , replProgramPaths :: [(String, FilePath)]+  , replProgramArgs :: [(String, [String])]+  , replReload :: Flag Bool+  , replReplOptions :: ReplOptions+  }+  deriving (Show, Generic)++instance Binary ReplFlags+instance Structured ReplFlags++defaultReplFlags :: ReplFlags+defaultReplFlags =+  ReplFlags+    { replCommonFlags = defaultCommonSetupFlags+    , replProgramPaths = mempty+    , replProgramArgs = []+    , replReload = Flag False+    , replReplOptions = mempty+    }++instance Monoid ReplFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ReplFlags where+  (<>) = gmappend++replCommand :: ProgramDb -> CommandUI ReplFlags+replCommand progDb =+  CommandUI+    { commandName = "repl"+    , commandSynopsis =+        "Open an interpreter session for the given component."+    , commandDescription = Just $ \pname ->+        wrapText $+          "If the current directory contains no package, ignores COMPONENT "+            ++ "parameters and opens an interactive interpreter session.\n"+            ++ "\n"+            ++ "Otherwise, (re)configures with the given or default flags, and "+            ++ "loads the interpreter with the relevant modules. For executables, "+            ++ "tests and benchmarks, loads the main module (and its "+            ++ "dependencies); for libraries all exposed/other modules.\n"+            ++ "\n"+            ++ "The default component is the library itself, or the executable "+            ++ "if that is the only component.\n"+            ++ "\n"+            ++ "Support for loading specific modules is planned but not "+            ++ "implemented yet. For certain scenarios, `"+            ++ pname+            ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will "+            ++ "not (re)configure and you will have to specify the location of "+            ++ "other modules, if required.\n"+    , commandNotes = Just $ \pname ->+        "Examples:\n"+          ++ "  "+          ++ pname+          ++ " repl           "+          ++ "    The first component in the package\n"+          ++ "  "+          ++ pname+          ++ " repl foo       "+          ++ "    A named component (i.e. lib, exe, test suite)\n"+          ++ "  "+          ++ pname+          ++ " repl --repl-options=\"-lstdc++\""+          ++ "  Specifying flags for interpreter\n"+    , -- TODO: re-enable once we have support for module/file targets+      --        ++ "  " ++ pname ++ " repl Foo.Bar   "+      --        ++ "    A module\n"+      --        ++ "  " ++ pname ++ " repl Foo/Bar.hs"+      --        ++ "    A file\n\n"+      --        ++ "If a target is ambiguous it can be qualified with the component "+      --        ++ "name, e.g.\n"+      --        ++ "  " ++ pname ++ " repl foo:Foo.Bar\n"+      --        ++ "  " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n"+      commandUsage = \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n"+    , commandDefaultFlags = defaultReplFlags+    , commandOptions = \showOrParseArgs ->+        withCommonSetupOptions+          replCommonFlags+          (\c f -> f{replCommonFlags = c})+          showOrParseArgs+          $ programDbPaths+            progDb+            showOrParseArgs+            replProgramPaths+            (\v flags -> flags{replProgramPaths = v})+            ++ programDbOption+              progDb+              showOrParseArgs+              replProgramArgs+              (\v flags -> flags{replProgramArgs = v})+            ++ programDbOptions+              progDb+              showOrParseArgs+              replProgramArgs+              (\v flags -> flags{replProgramArgs = v})+            ++ case showOrParseArgs of+              ParseArgs ->+                [ option+                    ""+                    ["reload"]+                    "Used from within an interpreter to update files."+                    replReload+                    (\v flags -> flags{replReload = v})+                    trueArg+                ]+              _ -> []+            ++ map liftReplOption (replOptions showOrParseArgs)+    }+  where+    liftReplOption = liftOption replReplOptions (\v flags -> flags{replReplOptions = v})++replOptions :: ShowOrParseArgs -> [OptionField ReplOptions]+replOptions _ =+  [ option+      []+      ["repl-no-load"]+      "Disable loading of project modules at REPL startup."+      replOptionsNoLoad+      (\p flags -> flags{replOptionsNoLoad = p})+      trueArg+  , option+      []+      ["repl-options"]+      "Use the option(s) for the repl"+      replOptionsFlags+      (\p flags -> flags{replOptionsFlags = p})+      (reqArg "FLAG" (succeedReadE words) id)+  , option+      []+      ["repl-multi-file"]+      "Write repl options to this directory rather than starting repl mode"+      replOptionsFlagOutput+      (\p flags -> flags{replOptionsFlagOutput = p})+      (reqArg "DIR" (succeedReadE Flag) flagToList)+  , option+      []+      ["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
@@ -0,0 +1,141 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :  Distribution.Simple.Setup.SDist+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Definition of the sdist command-line options.+-- See: @Distribution.Simple.Setup@+module Distribution.Simple.Setup.SDist+  ( SDistFlags+      ( SDistCommonFlags+      , sDistVerbosity+      , sDistDistPref+      , sDistCabalFilePath+      , sDistWorkingDir+      , sDistTargets+      , ..+      )+  , emptySDistFlags+  , defaultSDistFlags+  , sdistCommand+  ) where++import Distribution.Compat.Prelude hiding (get)+import Prelude ()++import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import Distribution.Simple.Flag+import Distribution.Simple.Setup.Common+import Distribution.Utils.Path+import Distribution.Verbosity++-- ------------------------------------------------------------++-- * SDist flags++-- ------------------------------------------------------------++-- | Flags to @sdist@: (snapshot, verbosity)+data SDistFlags = SDistFlags+  { sDistCommonFlags :: !CommonSetupFlags+  , sDistSnapshot :: Flag Bool+  , sDistDirectory :: Flag FilePath+  , sDistListSources :: Flag FilePath+  }+  deriving (Show, Generic)++pattern SDistCommonFlags+  :: Flag Verbosity+  -> Flag (SymbolicPath Pkg (Dir Dist))+  -> Flag (SymbolicPath CWD (Dir Pkg))+  -> Flag (SymbolicPath Pkg File)+  -> [String]+  -> SDistFlags+pattern SDistCommonFlags+  { sDistVerbosity+  , sDistDistPref+  , sDistWorkingDir+  , sDistCabalFilePath+  , sDistTargets+  } <-+  ( sDistCommonFlags ->+      CommonSetupFlags+        { setupVerbosity = sDistVerbosity+        , setupDistPref = sDistDistPref+        , setupWorkingDir = sDistWorkingDir+        , setupCabalFilePath = sDistCabalFilePath+        , setupTargets = sDistTargets+        }+    )++defaultSDistFlags :: SDistFlags+defaultSDistFlags =+  SDistFlags+    { sDistCommonFlags = defaultCommonSetupFlags+    , sDistSnapshot = Flag False+    , sDistDirectory = mempty+    , sDistListSources = mempty+    }++sdistCommand :: CommandUI SDistFlags+sdistCommand =+  CommandUI+    { commandName = "sdist"+    , commandSynopsis =+        "Generate a source distribution file (.tar.gz)."+    , commandDescription = Nothing+    , commandNotes = Nothing+    , commandUsage = \pname ->+        "Usage: " ++ pname ++ " sdist [FLAGS]\n"+    , commandDefaultFlags = defaultSDistFlags+    , commandOptions = \showOrParseArgs ->+        withCommonSetupOptions+          sDistCommonFlags+          (\c f -> f{sDistCommonFlags = c})+          showOrParseArgs+          [ option+              ""+              ["list-sources"]+              "Just write a list of the package's sources to a file"+              sDistListSources+              (\v flags -> flags{sDistListSources = v})+              (reqArgFlag "FILE")+          , option+              ""+              ["snapshot"]+              "Produce a snapshot source distribution"+              sDistSnapshot+              (\v flags -> flags{sDistSnapshot = v})+              trueArg+          , option+              ""+              ["output-directory"]+              ( "Generate a source distribution in the given directory, "+                  ++ "without creating a tarball"+              )+              sDistDirectory+              (\v flags -> flags{sDistDirectory = v})+              (reqArgFlag "DIR")+          ]+    }++emptySDistFlags :: SDistFlags+emptySDistFlags = mempty++instance Monoid SDistFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup SDistFlags where+  (<>) = gmappend
+ src/Distribution/Simple/Setup/Test.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :  Distribution.Simple.Test+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Definition of the testing command-line options.+-- See: @Distribution.Simple.Setup@+module Distribution.Simple.Setup.Test+  ( TestFlags+      ( TestCommonFlags+      , testVerbosity+      , testDistPref+      , testCabalFilePath+      , testWorkingDir+      , testTargets+      , ..+      )+  , emptyTestFlags+  , defaultTestFlags+  , testCommand+  , TestShowDetails (..)+  , testOptions'+  ) where++import Distribution.Compat.Prelude hiding (get)+import Prelude ()++import qualified Distribution.Compat.CharParsing as P+import Distribution.Parsec+import Distribution.Pretty+import Distribution.ReadE+import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import Distribution.Simple.Flag+import Distribution.Simple.InstallDirs+import Distribution.Simple.Setup.Common+import Distribution.Simple.Utils+import Distribution.Utils.Path+import Distribution.Verbosity++import qualified Text.PrettyPrint as Disp++-- ------------------------------------------------------------++-- * Test flags++-- ------------------------------------------------------------++data TestShowDetails = Never | Failures | Always | Streaming | Direct+  deriving (Eq, Ord, Enum, Bounded, Generic, Show)++instance Binary TestShowDetails+instance Structured TestShowDetails++knownTestShowDetails :: [TestShowDetails]+knownTestShowDetails = [minBound .. maxBound]++instance Pretty TestShowDetails where+  pretty = Disp.text . lowercase . show++instance Parsec TestShowDetails where+  parsec = maybe (fail "invalid TestShowDetails") return . classify =<< ident+    where+      ident = P.munch1 (\c -> isAlpha c || c == '_' || c == '-')+      classify str = lookup (lowercase str) enumMap+      enumMap :: [(String, TestShowDetails)]+      enumMap =+        [ (prettyShow x, x)+        | x <- knownTestShowDetails+        ]++-- TODO: do we need this instance?+instance Monoid TestShowDetails where+  mempty = Never+  mappend = (<>)++instance Semigroup TestShowDetails where+  a <> b = if a < b then b else a++data TestFlags = TestFlags+  { testCommonFlags :: !CommonSetupFlags+  , testHumanLog :: Flag PathTemplate+  , testMachineLog :: Flag PathTemplate+  , testShowDetails :: Flag TestShowDetails+  , testKeepTix :: Flag Bool+  , testWrapper :: Flag FilePath+  , testFailWhenNoTestSuites :: Flag Bool+  , -- TODO: think about if/how options are passed to test exes+    testOptions :: [PathTemplate]+  }+  deriving (Show, Generic)++pattern TestCommonFlags+  :: Flag Verbosity+  -> Flag (SymbolicPath Pkg (Dir Dist))+  -> Flag (SymbolicPath CWD (Dir Pkg))+  -> Flag (SymbolicPath Pkg File)+  -> [String]+  -> TestFlags+pattern TestCommonFlags+  { testVerbosity+  , testDistPref+  , testWorkingDir+  , testCabalFilePath+  , testTargets+  } <-+  ( testCommonFlags ->+      CommonSetupFlags+        { setupVerbosity = testVerbosity+        , setupDistPref = testDistPref+        , setupWorkingDir = testWorkingDir+        , setupCabalFilePath = testCabalFilePath+        , setupTargets = testTargets+        }+    )++instance Binary TestFlags+instance Structured TestFlags++defaultTestFlags :: TestFlags+defaultTestFlags =+  TestFlags+    { testCommonFlags = defaultCommonSetupFlags+    , testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log"+    , testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log"+    , testShowDetails = toFlag Direct+    , testKeepTix = toFlag False+    , testWrapper = NoFlag+    , testFailWhenNoTestSuites = toFlag False+    , testOptions = []+    }++testCommand :: CommandUI TestFlags+testCommand =+  CommandUI+    { commandName = "test"+    , commandSynopsis =+        "Run all/specific tests in the test suite."+    , commandDescription = Just $ \_pname ->+        wrapText $+          testOrBenchmarkHelpText "test"+    , commandNotes = Nothing+    , commandUsage =+        usageAlternatives+          "test"+          [ "[FLAGS]"+          , "TESTCOMPONENTS [FLAGS]"+          ]+    , commandDefaultFlags = defaultTestFlags+    , commandOptions = testOptions'+    }++testOptions' :: ShowOrParseArgs -> [OptionField TestFlags]+testOptions' showOrParseArgs =+  withCommonSetupOptions+    testCommonFlags+    (\c f -> f{testCommonFlags = c})+    showOrParseArgs+    [ option+        []+        ["log"]+        ( "Log all test suite results to file (name template can use "+            ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)"+        )+        testHumanLog+        (\v flags -> flags{testHumanLog = v})+        ( reqArg'+            "TEMPLATE"+            (toFlag . toPathTemplate)+            (flagToList . fmap fromPathTemplate)+        )+    , option+        []+        ["machine-log"]+        ( "Produce a machine-readable log file (name template can use "+            ++ "$pkgid, $compiler, $os, $arch, $result)"+        )+        testMachineLog+        (\v flags -> flags{testMachineLog = v})+        ( reqArg'+            "TEMPLATE"+            (toFlag . toPathTemplate)+            (flagToList . fmap fromPathTemplate)+        )+    , option+        []+        ["show-details"]+        ( "'always': always show results of individual test cases. "+            ++ "'never': never show results of individual test cases. "+            ++ "'failures': show results of failing test cases. "+            ++ "'streaming': show results of test cases in real time."+            ++ "'direct': send results of test cases in real time; no log file."+        )+        testShowDetails+        (\v flags -> flags{testShowDetails = v})+        ( reqArg+            "FILTER"+            ( parsecToReadE+                ( \_ ->+                    "--show-details flag expects one of "+                      ++ intercalate+                        ", "+                        (map prettyShow knownTestShowDetails)+                )+                (fmap toFlag parsec)+            )+            (flagToList . fmap prettyShow)+        )+    , option+        []+        ["keep-tix-files"]+        "keep .tix files for HPC between test runs"+        testKeepTix+        (\v flags -> flags{testKeepTix = v})+        trueArg+    , option+        []+        ["test-wrapper"]+        "Run test through a wrapper."+        testWrapper+        (\v flags -> flags{testWrapper = v})+        ( reqArg'+            "FILE"+            (toFlag :: FilePath -> Flag FilePath)+            (flagToList :: Flag FilePath -> [FilePath])+        )+    , option+        []+        ["fail-when-no-test-suites"]+        ("Exit with failure when no test suites are found.")+        testFailWhenNoTestSuites+        (\v flags -> flags{testFailWhenNoTestSuites = v})+        trueArg+    , option+        []+        ["test-options"]+        ( "give extra options to test executables "+            ++ "(split on spaces, use \"\" to prevent splitting; "+            ++ "name templates can use $pkgid, $compiler, "+            ++ "$os, $arch, $test-suite)"+        )+        testOptions+        (\v flags -> flags{testOptions = v})+        ( reqArg'+            "TEMPLATES"+            (map toPathTemplate . splitArgs)+            (const [])+        )+    , option+        []+        ["test-option"]+        ( "give extra option to test executables "+            ++ "(passed directly as a single argument; "+            ++ "name template can use $pkgid, $compiler, "+            ++ "$os, $arch, $test-suite)"+        )+        testOptions+        (\v flags -> flags{testOptions = v})+        ( reqArg'+            "TEMPLATE"+            (\x -> [toPathTemplate x])+            (map fromPathTemplate)+        )+    ]++emptyTestFlags :: TestFlags+emptyTestFlags = mempty++instance Monoid TestFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup TestFlags where+  (<>) = gmappend
+ src/Distribution/Simple/SetupHooks/Errors.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StandaloneDeriving #-}++-----------------------------------------------------------------------------++-- Module      :  Distribution.Simple.SetupHooks.Errors+-- Copyright   :+-- License     :+--+-- Maintainer  :+-- Portability :+--+-- Exceptions for the Hooks build-type.++module Distribution.Simple.SetupHooks.Errors+  ( SetupHooksException (..)+  , CannotApplyComponentDiffReason (..)+  , IllegalComponentDiffReason (..)+  , RulesException (..)+  , setupHooksExceptionCode+  , setupHooksExceptionMessage+  ) where++import Distribution.PackageDescription+import Distribution.Simple.SetupHooks.Rule+import qualified Distribution.Simple.SetupHooks.Rule as Rule+import Distribution.Types.Component++import qualified Data.Graph as Graph+import Data.List+  ( intercalate+  )+import qualified Data.List.NonEmpty as NE+import qualified Data.Tree as Tree++--------------------------------------------------------------------------------++-- | An error involving the @SetupHooks@ module of a package with+-- Hooks build-type.+data SetupHooksException+  = -- | Cannot apply a diff to a component in a per-component configure hook.+    CannotApplyComponentDiff CannotApplyComponentDiffReason+  | -- | An error with pre-build rules.+    RulesException RulesException+  deriving (Show)++-- | AN error involving the @Rules@ in the @SetupHooks@ module of a+-- package with the Hooks build-type.+data RulesException+  = -- | There are cycles in the dependency graph of fine-grained rules.+    CyclicRuleDependencies+      (NE.NonEmpty (RuleBinary, [Graph.Tree RuleBinary]))+  | -- | When executing fine-grained rules compiled into the external hooks+    -- executable, we failed to find dependencies of a rule.+    CantFindSourceForRuleDependencies+      RuleBinary+      (NE.NonEmpty Rule.Location)+      -- ^ missing dependencies+  | -- | When executing fine-grained rules compiled into the external hooks+    -- executable, a rule failed to generate the outputs it claimed it would.+    MissingRuleOutputs+      RuleBinary+      (NE.NonEmpty Rule.Location)+      -- ^ missing outputs+  | -- | An invalid reference to a rule output, e.g. an out-of-range+    -- index.+    InvalidRuleOutputIndex+      RuleId+      -- ^ rule+      RuleId+      -- ^ dependency+      (NE.NonEmpty Rule.Location)+      -- ^ outputs of dependency+      Word+      -- ^ the invalid index+  | -- | A duplicate 'RuleId' in the construction of pre-build rules.+    DuplicateRuleId !RuleId !Rule !Rule++deriving instance Show RulesException++data CannotApplyComponentDiffReason+  = MismatchedComponentTypes Component Component+  | IllegalComponentDiff Component (NE.NonEmpty IllegalComponentDiffReason)+  deriving (Show)++data IllegalComponentDiffReason+  = CannotChangeName+  | CannotChangeComponentField String+  | CannotChangeBuildInfoField String+  deriving (Show)++setupHooksExceptionCode :: SetupHooksException -> Int+setupHooksExceptionCode = \case+  CannotApplyComponentDiff rea ->+    cannotApplyComponentDiffCode rea+  RulesException rea ->+    rulesExceptionCode rea++rulesExceptionCode :: RulesException -> Int+rulesExceptionCode = \case+  CyclicRuleDependencies{} -> 9077+  CantFindSourceForRuleDependencies{} -> 1071+  MissingRuleOutputs{} -> 3498+  InvalidRuleOutputIndex{} -> 1173+  DuplicateRuleId{} -> 7717++setupHooksExceptionMessage :: SetupHooksException -> String+setupHooksExceptionMessage = \case+  CannotApplyComponentDiff reason ->+    cannotApplyComponentDiffMessage reason+  RulesException reason ->+    rulesExceptionMessage reason++rulesExceptionMessage :: RulesException -> String+rulesExceptionMessage = \case+  CyclicRuleDependencies cycles ->+    unlines $+      ("Hooks: cycle" ++ plural ++ " in dependency structure of rules:")+        : map showCycle (NE.toList cycles)+    where+      plural :: String+      plural+        | NE.length cycles >= 2 =+            "s"+        | otherwise =+            ""+      showCycle :: (RuleBinary, [Graph.Tree RuleBinary]) -> String+      showCycle (r, rs) =+        unlines . map ("  " ++) . lines $+          Tree.drawTree $+            fmap showRule $+              Tree.Node r rs+  CantFindSourceForRuleDependencies _r deps ->+    unlines $+      ("Pre-build rules: can't find source for rule " ++ what ++ ":")+        : map (\d -> "  - " <> show d) depsL+    where+      depsL = NE.toList deps+      what+        | length depsL == 1 =+            "dependency"+        | otherwise =+            "dependencies"+  MissingRuleOutputs _r reslts ->+    unlines $+      ("Pre-build rule did not generate expected result" <> plural <> ":")+        : map (\res -> "  - " <> show res) resultsL+    where+      resultsL = NE.toList reslts+      plural+        | length resultsL == 1 =+            ""+        | otherwise =+            "s"+  InvalidRuleOutputIndex rId depRuleId outputs i -> unlines [header, body]+    where+      header = "Invalid index '" ++ show i ++ "' in dependency of " ++ show rId ++ "."+      nbOutputs = NE.length outputs+      body+        | (fromIntegral i :: Int) >= 0 =+            unwords+              [ "The dependency"+              , show depRuleId+              , "only has"+              , show nbOutputs+              , "output" ++ plural ++ "."+              ]+        | otherwise =+            "The index is too large."+      plural = if nbOutputs == 1 then "" else "s"+  DuplicateRuleId rId r1 r2 ->+    unlines $+      [ "Duplicate pre-build rule (" <> show rId <> ")"+      , "  - " <> showRule (ruleBinary r1)+      , "  - " <> showRule (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+  MismatchedComponentTypes{} -> 9491+  IllegalComponentDiff{} -> 7634++cannotApplyComponentDiffMessage :: CannotApplyComponentDiffReason -> String+cannotApplyComponentDiffMessage = \case+  MismatchedComponentTypes comp diff ->+    unlines+      [ "Hooks: mismatched component types in per-component configure hook."+      , "Trying to apply " ++ what ++ " diff to " ++ to ++ "."+      ]+    where+      what = case diff of+        CLib{} -> "a library"+        CFLib{} -> "a foreign library"+        CExe{} -> "an executable"+        CTest{} -> "a testsuite"+        CBench{} -> "a benchmark"+      to = case componentName comp of+        nm@(CExeName{}) -> "an " ++ showComponentName nm+        nm -> "a " ++ showComponentName nm+  IllegalComponentDiff comp reasons ->+    unlines $+      ("Hooks: illegal component diff in per-component pre-configure hook for " ++ what ++ ":")+        : map mk_rea (NE.toList reasons)+    where+      mk_rea err = "  - " ++ illegalComponentDiffMessage err ++ "."+      what = case componentName comp of+        CLibName LMainLibName -> "main library"+        nm -> showComponentName nm++illegalComponentDiffMessage :: IllegalComponentDiffReason -> String+illegalComponentDiffMessage = \case+  CannotChangeName ->+    "cannot change the name of a component"+  CannotChangeComponentField fld ->+    "cannot change component field '" ++ fld ++ "'"+  CannotChangeBuildInfoField fld ->+    "cannot change BuildInfo field '" ++ fld ++ "'"
+ src/Distribution/Simple/SetupHooks/Internal.hs view
@@ -0,0 +1,1095 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module: Distribution.Simple.SetupHooks.Internal+--+-- Internal implementation module.+-- Users of @build-type: Hooks@ should import "Distribution.Simple.SetupHooks"+-- instead.+module Distribution.Simple.SetupHooks.Internal+  ( -- * The setup hooks datatype+    SetupHooks (..)+  , noSetupHooks++    -- * Configure hooks+  , ConfigureHooks (..)+  , noConfigureHooks++    -- ** Per-package configure hooks+  , PreConfPackageInputs (..)+  , PreConfPackageOutputs (..)+  , noPreConfPackageOutputs+  , PreConfPackageHook+  , PostConfPackageInputs (..)+  , PostConfPackageHook++    -- ** Per-component configure hooks+  , PreConfComponentInputs (..)+  , PreConfComponentOutputs (..)+  , noPreConfComponentOutputs+  , PreConfComponentHook+  , ComponentDiff (..)+  , emptyComponentDiff+  , buildInfoComponentDiff+  , LibraryDiff+  , ForeignLibDiff+  , ExecutableDiff+  , TestSuiteDiff+  , BenchmarkDiff+  , BuildInfoDiff++    -- * Build hooks+  , BuildHooks (..)+  , noBuildHooks+  , BuildingWhat (..)+  , buildingWhatVerbosity+  , buildingWhatWorkingDir+  , buildingWhatDistPref++    -- ** Pre-build rules+  , PreBuildComponentInputs (..)+  , PreBuildComponentRules++    -- ** Post-build hook+  , PostBuildComponentInputs (..)+  , PostBuildComponentHook++    -- * Install hooks+  , InstallHooks (..)+  , noInstallHooks+  , InstallComponentInputs (..)+  , InstallComponentHook++    -- * Internals++    -- ** Per-component hook utilities+  , applyComponentDiffs+  , forComponents_++    -- ** Executing build rules+  , executeRules++    -- ** HookedBuildInfo compatibility code+  , hookedBuildInfoComponents+  , hookedBuildInfoComponentDiff_maybe+  )+where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Compat.Lens ((.~))+import Distribution.PackageDescription+import Distribution.Simple.BuildPaths+import Distribution.Simple.Compiler (Compiler (..))+import Distribution.Simple.Errors+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Program.Db+import Distribution.Simple.Setup+  ( BuildingWhat (..)+  , buildingWhatDistPref+  , buildingWhatVerbosity+  , buildingWhatWorkingDir+  )+import Distribution.Simple.Setup.Build (BuildFlags (..))+import Distribution.Simple.Setup.Config (ConfigFlags (..))+import Distribution.Simple.Setup.Copy (CopyFlags (..))+import Distribution.Simple.SetupHooks.Errors+import Distribution.Simple.SetupHooks.Rule+import qualified Distribution.Simple.SetupHooks.Rule as Rule+import Distribution.Simple.Utils+import Distribution.System (Platform (..))+import Distribution.Utils.Path++import 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.Lazy as LBS+import Data.Coerce (coerce)+import qualified Data.Graph as Graph+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import qualified Data.Set as Set++import System.Directory (doesFileExist)++--------------------------------------------------------------------------------+-- SetupHooks++-- | Hooks into the @cabal@ build phases.+--+-- Usage:+--+--  - In your @.cabal@ file, declare @build-type: Hooks@+--    (with a @cabal-version@ greater than or equal to @3.14@),+--  - In your @.cabal@ file, include a @custom-setup@ stanza+--    which declares the dependencies of your @SetupHooks@ module;+--    this will usually contain a dependency on the @Cabal-hooks@ package.+--  - Provide a @SetupHooks.hs@ module next to your @.cabal@ file;+--    it must export @setupHooks :: SetupHooks@.+data SetupHooks = SetupHooks+  { configureHooks :: ConfigureHooks+  -- ^ Hooks into the configure phase.+  , buildHooks :: BuildHooks+  -- ^ Hooks into the build phase.+  --+  -- These hooks are relevant to any build-like phase,+  -- such as repl or haddock.+  , installHooks :: InstallHooks+  -- ^ Hooks into the copy/install phase.+  }++-- | 'SetupHooks' can be combined monoidally. This is useful to combine+-- setup hooks defined by another package with your own package-specific+-- hooks.+--+-- __Warning__: this 'Semigroup' instance is not commutative.+instance Semigroup SetupHooks where+  SetupHooks+    { configureHooks = conf1+    , buildHooks = build1+    , installHooks = inst1+    }+    <> SetupHooks+      { configureHooks = conf2+      , buildHooks = build2+      , installHooks = inst2+      } =+      SetupHooks+        { configureHooks = conf1 <> conf2+        , buildHooks = build1 <> build2+        , installHooks = inst1 <> inst2+        }++instance Monoid SetupHooks where+  mempty = noSetupHooks++-- | Empty hooks.+noSetupHooks :: SetupHooks+noSetupHooks =+  SetupHooks+    { configureHooks = noConfigureHooks+    , buildHooks = noBuildHooks+    , installHooks = noInstallHooks+    }++--------------------------------------------------------------------------------+-- Configure hooks.++type PreConfPackageHook = PreConfPackageInputs -> IO PreConfPackageOutputs++-- | Inputs to the package-wide pre-configure step.+data PreConfPackageInputs = PreConfPackageInputs+  { configFlags :: ConfigFlags+  , localBuildConfig :: LocalBuildConfig+  -- ^ Warning: the 'ProgramDb' in the 'withPrograms' field+  -- will not contain any unconfigured programs.+  , compiler :: Compiler+  , platform :: Platform+  }+  deriving (Generic, Show)++-- | Outputs of the package-wide pre-configure step.+--+-- Prefer using 'noPreConfPackageOutputs' and overriding the fields+-- you care about, to avoid depending on implementation details+-- of this datatype.+data PreConfPackageOutputs = PreConfPackageOutputs+  { buildOptions :: BuildOptions+  , extraConfiguredProgs :: ConfiguredProgs+  }+  deriving (Generic, Show)++-- | Use this smart constructor to declare an empty set of changes+-- by the package-wide pre-configure hook, and override the fields you+-- care about.+--+-- Use this rather than v'PreConfPackageOutputs' to avoid relying on+-- internal implementation details of the latter.+noPreConfPackageOutputs :: PreConfPackageInputs -> PreConfPackageOutputs+noPreConfPackageOutputs (PreConfPackageInputs{localBuildConfig = lbc}) =+  PreConfPackageOutputs+    { buildOptions = LBC.withBuildOptions lbc+    , extraConfiguredProgs = Map.empty+    }++-- | Package-wide post-configure step.+--+-- Perform side effects. Last opportunity for any package-wide logic;+-- any subsequent hooks work per-component.+type PostConfPackageHook = PostConfPackageInputs -> IO ()++-- | Inputs to the package-wide post-configure step.+data PostConfPackageInputs = PostConfPackageInputs+  { localBuildConfig :: LocalBuildConfig+  , packageBuildDescr :: PackageBuildDescr+  }+  deriving (Generic, Show)++-- | Per-component pre-configure step.+--+-- For each component of the package, this hook can perform side effects,+-- and return a diff to the passed in component, e.g. to declare additional+-- autogenerated modules.+type PreConfComponentHook = PreConfComponentInputs -> IO PreConfComponentOutputs++-- | Inputs to the per-component pre-configure step.+data PreConfComponentInputs = PreConfComponentInputs+  { localBuildConfig :: LocalBuildConfig+  , packageBuildDescr :: PackageBuildDescr+  , component :: Component+  }+  deriving (Generic, Show)++-- | Outputs of the per-component pre-configure step.+--+-- Prefer using 'noPreComponentOutputs' and overriding the fields+-- you care about, to avoid depending on implementation details+-- of this datatype.+data PreConfComponentOutputs = PreConfComponentOutputs+  { componentDiff :: ComponentDiff+  }+  deriving (Generic, Show)++-- | Use this smart constructor to declare an empty set of changes+-- by a per-component pre-configure hook, and override the fields you+-- care about.+--+-- Use this rather than v'PreConfComponentOutputs' to avoid relying on+-- internal implementation details of the latter.+noPreConfComponentOutputs :: PreConfComponentInputs -> PreConfComponentOutputs+noPreConfComponentOutputs (PreConfComponentInputs{component = comp}) =+  PreConfComponentOutputs+    { componentDiff = emptyComponentDiff (componentName comp)+    }++-- | Configure-time hooks.+--+-- Order of execution:+--+--  - 'preConfPackageHook',+--  - configure the package,+--  - 'postConfPackageHook',+--  - 'preConfComponentHook',+--  - configure the components.+data ConfigureHooks = ConfigureHooks+  { preConfPackageHook :: Maybe PreConfPackageHook+  -- ^ Package-wide pre-configure hook. See 'PreConfPackageHook'.+  , postConfPackageHook :: Maybe PostConfPackageHook+  -- ^ Package-wide post-configure hook. See 'PostConfPackageHook'.+  , preConfComponentHook :: Maybe PreConfComponentHook+  -- ^ Per-component pre-configure hook. See 'PreConfComponentHook'.+  }++-- Note: these configure hooks don't track any kind of dependency information,+-- so we won't know when the configuration is out of date and should be re-done.+-- This seems okay: it should only matter while developing the package, in which+-- case it seems acceptable to rely on the user re-configuring.++instance Semigroup ConfigureHooks where+  ConfigureHooks+    { preConfPackageHook = prePkg1+    , postConfPackageHook = postPkg1+    , preConfComponentHook = preComp1+    }+    <> ConfigureHooks+      { preConfPackageHook = prePkg2+      , postConfPackageHook = postPkg2+      , preConfComponentHook = preComp2+      } =+      ConfigureHooks+        { preConfPackageHook =+            coerce+              ((<>) @(Maybe PreConfPkgSemigroup))+              prePkg1+              prePkg2+        , postConfPackageHook =+            postPkg1 <> postPkg2+        , preConfComponentHook =+            coerce+              ((<>) @(Maybe PreConfComponentSemigroup))+              preComp1+              preComp2+        }++instance Monoid ConfigureHooks where+  mempty = noConfigureHooks++-- | Empty configure phase hooks.+noConfigureHooks :: ConfigureHooks+noConfigureHooks =+  ConfigureHooks+    { preConfPackageHook = Nothing+    , postConfPackageHook = Nothing+    , preConfComponentHook = Nothing+    }++-- | A newtype to hang off the @Semigroup PreConfPackageHook@ instance.+newtype PreConfPkgSemigroup = PreConfPkgSemigroup PreConfPackageHook++instance Semigroup PreConfPkgSemigroup where+  PreConfPkgSemigroup f1 <> PreConfPkgSemigroup f2 =+    PreConfPkgSemigroup $+      \inputs@( PreConfPackageInputs+                  { configFlags = cfg+                  , compiler = comp+                  , platform = plat+                  , localBuildConfig = lbc0+                  }+                ) ->+          do+            PreConfPackageOutputs+              { buildOptions = opts1+              , extraConfiguredProgs = progs1+              } <-+              f1 inputs+            PreConfPackageOutputs+              { buildOptions = opts2+              , extraConfiguredProgs = progs2+              } <-+              f2 $+                PreConfPackageInputs+                  { configFlags = cfg+                  , compiler = comp+                  , platform = plat+                  , localBuildConfig =+                      lbc0+                        { LBC.withPrograms =+                            updateConfiguredProgs (`Map.union` progs1) $+                              LBC.withPrograms lbc0+                        , LBC.withBuildOptions = opts1+                        }+                  }+            return $+              PreConfPackageOutputs+                { buildOptions = opts2+                , extraConfiguredProgs = progs1 <> progs2+                }++-- | A newtype to hang off the @Semigroup PreConfComponentHook@ instance.+newtype PreConfComponentSemigroup = PreConfComponentSemigroup PreConfComponentHook++instance Semigroup PreConfComponentSemigroup where+  PreConfComponentSemigroup f1 <> PreConfComponentSemigroup f2 =+    PreConfComponentSemigroup $ \inputs ->+      do+        PreConfComponentOutputs+          { componentDiff = diff1+          } <-+          f1 inputs+        PreConfComponentOutputs+          { componentDiff = diff2+          } <-+          f2 inputs+        return $+          PreConfComponentOutputs+            { componentDiff = diff1 <> diff2+            }++--------------------------------------------------------------------------------+-- Build setup hooks.++data PreBuildComponentInputs = PreBuildComponentInputs+  { buildingWhat :: BuildingWhat+  -- ^ what kind of build phase are we hooking into?+  , localBuildInfo :: LocalBuildInfo+  -- ^ information about the package+  , targetInfo :: TargetInfo+  -- ^ information about an individual component+  }+  deriving (Generic, Show)++type PreBuildComponentRules = Rules PreBuildComponentInputs++data PostBuildComponentInputs = PostBuildComponentInputs+  { buildFlags :: BuildFlags+  , localBuildInfo :: LocalBuildInfo+  , targetInfo :: TargetInfo+  }+  deriving (Generic, Show)++type PostBuildComponentHook = PostBuildComponentInputs -> IO ()++-- | Build-time hooks.+data BuildHooks = BuildHooks+  { preBuildComponentRules :: Maybe PreBuildComponentRules+  -- ^ Per-component fine-grained pre-build rules.+  , postBuildComponentHook :: Maybe PostBuildComponentHook+  -- ^ Per-component post-build hook.+  }++-- Note that the pre-build hook consists of a function which takes a component+-- as an argument (as part of the targetInfo field) and returns a collection of+-- pre-build rules.+--+-- One might wonder why it isn't instead a collection of pre-build rules, one+-- for each component. The reason is that Backpack creates components on-the-fly+-- through instantiation, which means e.g. that a single component name can+-- resolve to multiple components. This means we really need to pass in the+-- components to the function, as we don't know the full details (e.g. their+-- unit ids) ahead of time.++instance Semigroup BuildHooks where+  BuildHooks+    { preBuildComponentRules = rs1+    , postBuildComponentHook = post1+    }+    <> BuildHooks+      { preBuildComponentRules = rs2+      , postBuildComponentHook = post2+      } =+      BuildHooks+        { preBuildComponentRules = rs1 <> rs2+        , postBuildComponentHook = post1 <> post2+        }++instance Monoid BuildHooks where+  mempty = noBuildHooks++-- | Empty build hooks.+noBuildHooks :: BuildHooks+noBuildHooks =+  BuildHooks+    { preBuildComponentRules = Nothing+    , postBuildComponentHook = Nothing+    }++--------------------------------------------------------------------------------+-- Install setup hooks.++data InstallComponentInputs = InstallComponentInputs+  { copyFlags :: CopyFlags+  , localBuildInfo :: LocalBuildInfo+  , targetInfo :: TargetInfo+  }+  deriving (Generic, Show)++-- | A per-component install hook,+-- which can only perform side effects (e.g. copying files).+type InstallComponentHook = InstallComponentInputs -> IO ()++-- | Copy/install hooks.+data InstallHooks = InstallHooks+  { installComponentHook :: Maybe InstallComponentHook+  -- ^ Per-component install hook.+  }++instance Semigroup InstallHooks where+  InstallHooks+    { installComponentHook = inst1+    }+    <> InstallHooks+      { installComponentHook = inst2+      } =+      InstallHooks+        { installComponentHook = inst1 <> inst2+        }++instance Monoid InstallHooks where+  mempty = noInstallHooks++-- | Empty copy/install hooks.+noInstallHooks :: InstallHooks+noInstallHooks =+  InstallHooks+    { installComponentHook = Nothing+    }++--------------------------------------------------------------------------------+-- Per-component configure hook implementation details.++type LibraryDiff = Library+type ForeignLibDiff = ForeignLib+type ExecutableDiff = Executable+type TestSuiteDiff = TestSuite+type BenchmarkDiff = Benchmark+type BuildInfoDiff = BuildInfo++-- | A diff to a Cabal 'Component', that gets combined monoidally into+-- an existing 'Component'.+newtype ComponentDiff = ComponentDiff {componentDiff :: Component}+  deriving (Semigroup, Show)++emptyComponentDiff :: ComponentName -> ComponentDiff+emptyComponentDiff name = ComponentDiff $+  case name of+    CLibName{} -> CLib emptyLibrary+    CFLibName{} -> CFLib emptyForeignLib+    CExeName{} -> CExe emptyExecutable+    CTestName{} -> CTest emptyTestSuite+    CBenchName{} -> CBench emptyBenchmark++buildInfoComponentDiff :: ComponentName -> BuildInfo -> ComponentDiff+buildInfoComponentDiff name bi = ComponentDiff $+  BI.buildInfo .~ bi $+    case name of+      CLibName{} -> CLib emptyLibrary+      CFLibName{} -> CFLib emptyForeignLib+      CExeName{} -> CExe emptyExecutable+      CTestName{} -> CTest emptyTestSuite+      CBenchName{} -> CBench emptyBenchmark++applyLibraryDiff :: Verbosity -> Library -> LibraryDiff -> IO Library+applyLibraryDiff verbosity lib diff =+  case illegalLibraryDiffReasons lib diff of+    [] -> return $ lib <> diff+    (r : rs) ->+      dieWithException verbosity $+        SetupHooksException $+          CannotApplyComponentDiff $+            IllegalComponentDiff (CLib lib) (r NE.:| rs)++illegalLibraryDiffReasons :: Library -> LibraryDiff -> [IllegalComponentDiffReason]+illegalLibraryDiffReasons+  lib+  Library+    { libName = nm+    , libExposed = e+    , libVisibility = vis+    , libBuildInfo = bi+    } =+    [ CannotChangeName+    | not $ nm == libName emptyLibrary || nm == libName lib+    ]+      ++ [ CannotChangeComponentField "libExposed"+         | not $ e == libExposed emptyLibrary || e == libExposed lib+         ]+      ++ [ CannotChangeComponentField "libVisibility"+         | not $ vis == libVisibility emptyLibrary || vis == libVisibility lib+         ]+      ++ illegalBuildInfoDiffReasons (libBuildInfo lib) bi++applyForeignLibDiff :: Verbosity -> ForeignLib -> ForeignLibDiff -> IO ForeignLib+applyForeignLibDiff verbosity flib diff =+  case illegalForeignLibDiffReasons flib diff of+    [] -> return $ flib <> diff+    (r : rs) ->+      dieWithException verbosity $+        SetupHooksException $+          CannotApplyComponentDiff $+            IllegalComponentDiff (CFLib flib) (r NE.:| rs)++illegalForeignLibDiffReasons :: ForeignLib -> ForeignLibDiff -> [IllegalComponentDiffReason]+illegalForeignLibDiffReasons+  flib+  ForeignLib+    { foreignLibName = nm+    , foreignLibType = ty+    , foreignLibOptions = opts+    , foreignLibVersionInfo = vi+    , foreignLibVersionLinux = linux+    , foreignLibModDefFile = defs+    , foreignLibBuildInfo = bi+    } =+    [ CannotChangeName+    | not $ nm == foreignLibName emptyForeignLib || nm == foreignLibName flib+    ]+      ++ [ CannotChangeComponentField "foreignLibType"+         | not $ ty == foreignLibType emptyForeignLib || ty == foreignLibType flib+         ]+      ++ [ CannotChangeComponentField "foreignLibOptions"+         | not $ opts == foreignLibOptions emptyForeignLib || opts == foreignLibOptions flib+         ]+      ++ [ CannotChangeComponentField "foreignLibVersionInfo"+         | not $ vi == foreignLibVersionInfo emptyForeignLib || vi == foreignLibVersionInfo flib+         ]+      ++ [ CannotChangeComponentField "foreignLibVersionLinux"+         | not $ linux == foreignLibVersionLinux emptyForeignLib || linux == foreignLibVersionLinux flib+         ]+      ++ [ CannotChangeComponentField "foreignLibModDefFile"+         | not $ defs == foreignLibModDefFile emptyForeignLib || defs == foreignLibModDefFile flib+         ]+      ++ illegalBuildInfoDiffReasons (foreignLibBuildInfo flib) bi++applyExecutableDiff :: Verbosity -> Executable -> ExecutableDiff -> IO Executable+applyExecutableDiff verbosity exe diff =+  case illegalExecutableDiffReasons exe diff of+    [] -> return $ exe <> diff+    (r : rs) ->+      dieWithException verbosity $+        SetupHooksException $+          CannotApplyComponentDiff $+            IllegalComponentDiff (CExe exe) (r NE.:| rs)++illegalExecutableDiffReasons :: Executable -> ExecutableDiff -> [IllegalComponentDiffReason]+illegalExecutableDiffReasons+  exe+  Executable+    { exeName = nm+    , modulePath = path+    , exeScope = scope+    , buildInfo = bi+    } =+    [ CannotChangeName+    | not $ nm == exeName emptyExecutable || nm == exeName exe+    ]+      ++ [ CannotChangeComponentField "modulePath"+         | not $ path == modulePath emptyExecutable || path == modulePath exe+         ]+      ++ [ CannotChangeComponentField "exeScope"+         | not $ scope == exeScope emptyExecutable || scope == exeScope exe+         ]+      ++ illegalBuildInfoDiffReasons (buildInfo exe) bi++applyTestSuiteDiff :: Verbosity -> TestSuite -> TestSuiteDiff -> IO TestSuite+applyTestSuiteDiff verbosity test diff =+  case illegalTestSuiteDiffReasons test diff of+    [] -> return $ test <> diff+    (r : rs) ->+      dieWithException verbosity $+        SetupHooksException $+          CannotApplyComponentDiff $+            IllegalComponentDiff (CTest test) (r NE.:| rs)++illegalTestSuiteDiffReasons :: TestSuite -> TestSuiteDiff -> [IllegalComponentDiffReason]+illegalTestSuiteDiffReasons+  test+  TestSuite+    { testName = nm+    , testInterface = iface+    , testCodeGenerators = gens+    , testBuildInfo = bi+    } =+    [ CannotChangeName+    | not $ nm == testName emptyTestSuite || nm == testName test+    ]+      ++ [ CannotChangeComponentField "testInterface"+         | not $ iface == testInterface emptyTestSuite || iface == testInterface test+         ]+      ++ [ CannotChangeComponentField "testCodeGenerators"+         | not $ gens == testCodeGenerators emptyTestSuite || gens == testCodeGenerators test+         ]+      ++ illegalBuildInfoDiffReasons (testBuildInfo test) bi++applyBenchmarkDiff :: Verbosity -> Benchmark -> BenchmarkDiff -> IO Benchmark+applyBenchmarkDiff verbosity bench diff =+  case illegalBenchmarkDiffReasons bench diff of+    [] -> return $ bench <> diff+    (r : rs) ->+      dieWithException verbosity $+        SetupHooksException $+          CannotApplyComponentDiff $+            IllegalComponentDiff (CBench bench) (r NE.:| rs)++illegalBenchmarkDiffReasons :: Benchmark -> BenchmarkDiff -> [IllegalComponentDiffReason]+illegalBenchmarkDiffReasons+  bench+  Benchmark+    { benchmarkName = nm+    , benchmarkInterface = iface+    , benchmarkBuildInfo = bi+    } =+    [ CannotChangeName+    | not $ nm == benchmarkName emptyBenchmark || nm == benchmarkName bench+    ]+      ++ [ CannotChangeComponentField "benchmarkInterface"+         | not $ iface == benchmarkInterface emptyBenchmark || iface == benchmarkInterface bench+         ]+      ++ illegalBuildInfoDiffReasons (benchmarkBuildInfo bench) bi++illegalBuildInfoDiffReasons :: BuildInfo -> BuildInfoDiff -> [IllegalComponentDiffReason]+illegalBuildInfoDiffReasons+  bi+  BuildInfo+    { buildable = can_build+    , buildTools = build_tools+    , buildToolDepends = build_tools_depends+    , pkgconfigDepends = pkgconfig_depends+    , frameworks = fworks+    , targetBuildDepends = target_build_depends+    } =+    map CannotChangeBuildInfoField $+      [ "buildable"+      | not $ can_build == buildable bi || can_build == buildable emptyBuildInfo+      ]+        ++ [ "buildTools"+           | not $ build_tools == buildTools bi || build_tools == buildTools emptyBuildInfo+           ]+        ++ [ "buildToolsDepends"+           | not $ build_tools_depends == buildToolDepends bi || build_tools_depends == buildToolDepends emptyBuildInfo+           ]+        ++ [ "pkgconfigDepends"+           | not $ pkgconfig_depends == pkgconfigDepends bi || pkgconfig_depends == pkgconfigDepends emptyBuildInfo+           ]+        ++ [ "frameworks"+           | not $ fworks == frameworks bi || fworks == frameworks emptyBuildInfo+           ]+        ++ [ "targetBuildDepends"+           | not $ target_build_depends == targetBuildDepends bi || target_build_depends == targetBuildDepends emptyBuildInfo+           ]++-- | Traverse the components of a 'PackageDescription'.+--+-- The function must preserve the component type, i.e. map a 'CLib' to a 'CLib',+-- a 'CExe' to a 'CExe', etc.+traverseComponents+  :: Applicative m+  => (Component -> m Component)+  -> PackageDescription+  -> m PackageDescription+traverseComponents f pd =+  upd_pd+    <$> traverse f_lib (library pd)+    <*> traverse f_lib (subLibraries pd)+    <*> traverse f_flib (foreignLibs pd)+    <*> traverse f_exe (executables pd)+    <*> traverse f_test (testSuites pd)+    <*> traverse f_bench (benchmarks pd)+  where+    f_lib lib = \case { CLib lib' -> lib'; c -> mismatch (CLib lib) c } <$> f (CLib lib)+    f_flib flib = \case { CFLib flib' -> flib'; c -> mismatch (CFLib flib) c } <$> f (CFLib flib)+    f_exe exe = \case { CExe exe' -> exe'; c -> mismatch (CExe exe) c } <$> f (CExe exe)+    f_test test = \case { CTest test' -> test'; c -> mismatch (CTest test) c } <$> f (CTest test)+    f_bench bench = \case { CBench bench' -> bench'; c -> mismatch (CBench bench) c } <$> f (CBench bench)++    upd_pd lib sublibs flibs exes tests benchs =+      pd+        { library = lib+        , subLibraries = sublibs+        , foreignLibs = flibs+        , executables = exes+        , testSuites = tests+        , benchmarks = benchs+        }++    -- This is a panic, because we maintain this invariant elsewhere:+    -- see 'componentDiffError' in 'applyComponentDiff', which catches an+    -- invalid per-component configure hook.+    mismatch c1 c2 =+      error $+        "Mismatched component types: "+          ++ showComponentName (componentName c1)+          ++ " "+          ++ showComponentName (componentName c2)+          ++ "."+{-# INLINEABLE traverseComponents #-}++applyComponentDiffs+  :: Verbosity+  -> (Component -> IO (Maybe ComponentDiff))+  -> PackageDescription+  -> IO PackageDescription+applyComponentDiffs verbosity f = traverseComponents apply_diff+  where+    apply_diff :: Component -> IO Component+    apply_diff c = do+      mbDiff <- f c+      case mbDiff of+        Just diff -> applyComponentDiff verbosity c diff+        Nothing -> return c++forComponents_ :: PackageDescription -> (Component -> IO ()) -> IO ()+forComponents_ pd f = getConst $ traverseComponents (Const . f) pd++applyComponentDiff+  :: Verbosity+  -> Component+  -> ComponentDiff+  -> IO Component+applyComponentDiff verbosity comp (ComponentDiff diff)+  | CLib lib <- comp+  , CLib lib_diff <- diff =+      CLib <$> applyLibraryDiff verbosity lib lib_diff+  | CFLib flib <- comp+  , CFLib flib_diff <- diff =+      CFLib <$> applyForeignLibDiff verbosity flib flib_diff+  | CExe exe <- comp+  , CExe exe_diff <- diff =+      CExe <$> applyExecutableDiff verbosity exe exe_diff+  | CTest test <- comp+  , CTest test_diff <- diff =+      CTest <$> applyTestSuiteDiff verbosity test test_diff+  | CBench bench <- comp+  , CBench bench_diff <- diff =+      CBench <$> applyBenchmarkDiff verbosity bench bench_diff+  | otherwise =+      componentDiffError $ MismatchedComponentTypes comp diff+  where+    -- The per-component configure hook specified a diff of the wrong type,+    -- e.g. tried to apply an executable diff to a library.+    componentDiffError err =+      dieWithException verbosity $+        SetupHooksException $+          CannotApplyComponentDiff err++--------------------------------------------------------------------------------+-- Running pre-build rules++-- | Run all pre-build rules.+--+-- This function should only be called internally within @Cabal@, as it is used+-- to implement the (legacy) Setup.hs interface. The build tool+-- (e.g. @cabal-install@ or @hls@) should instead go through the separate+-- hooks executable, which allows us to only rerun the out-of-date rules+-- (instead of running all of these rules at once).+executeRules+  :: Verbosity+  -> LocalBuildInfo+  -> TargetInfo+  -> Map RuleId Rule+  -> IO ()+executeRules =+  executeRulesUserOrSystem+    SUser+    (\_rId cmd -> sequenceA $ runRuleDynDepsCmd cmd)+    (\_rId cmd -> runRuleExecCmd cmd)++-- | Like 'executeRules', except it can be used when communicating with+-- an external hooks executable.+executeRulesUserOrSystem+  :: forall userOrSystem+   . SScope userOrSystem+  -> (RuleId -> RuleDynDepsCmd userOrSystem -> IO (Maybe ([Rule.Dependency], LBS.ByteString)))+  -> (RuleId -> RuleExecCmd userOrSystem -> IO ())+  -> Verbosity+  -> LocalBuildInfo+  -> TargetInfo+  -> Map RuleId (RuleData userOrSystem)+  -> IO ()+executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo allRules = do+  -- Compute all extra dynamic dependency edges.+  dynDepsEdges <-+    flip Map.traverseMaybeWithKey allRules $+      \rId (Rule{ruleCommands = cmds}) ->+        runDepsCmdData rId (ruleDepsCmd cmds)++  -- Create a build graph of all the rules, with static and dynamic dependencies+  -- as edges.+  let+    (ruleGraph, ruleFromVertex, vertexFromRuleId) =+      Graph.graphFromEdges+        [ (rule, rId, nub $ mapMaybe directRuleDependencyMaybe allDeps)+        | (rId, rule) <- Map.toList allRules+        , let dynDeps = fromMaybe [] (fst <$> Map.lookup rId dynDepsEdges)+              allDeps = staticDependencies rule ++ dynDeps+        ]++    -- Topologically sort the graph of rules.+    sccs = Graph.scc ruleGraph+    cycles = mapMaybe $ \(Graph.Node v0 subforest) ->+      case subforest of+        []+          | r@(_, rId, deps) <- ruleFromVertex v0 ->+              if rId `elem` deps+                then Just (r, [])+                else Nothing+        v : vs ->+          Just+            ( ruleFromVertex v0+            , map (fmap ruleFromVertex) (v : vs)+            )++    -- Compute demanded rules.+    --+    -- SetupHooks TODO: maybe requiring all generated modules to appear+    -- in autogen-modules is excessive; we can look through all modules instead.+    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+    demandedRuleVerts = Set.fromList $ concatMap (Graph.reachable ruleGraph) leafRules+    nonDemandedRuleVerts = Set.fromList (Graph.vertices ruleGraph) Set.\\ demandedRuleVerts++  case cycles sccs of+    -- If there are cycles in the dependency structure, don't execute+    -- any rules at all; just throw an error right off the bat.+    r : rs ->+      let getRule ((ru, _, _), js) = (toRuleBinary ru, fmap (fmap (\(rv, _, _) -> toRuleBinary rv)) js)+       in errorOut $+            CyclicRuleDependencies $+              fmap getRule (r NE.:| rs)+    -- Otherwise, run all the demanded rules in dependency order (in one go).+    -- (Fine-grained running of rules should happen in cabal-install or HLS,+    -- not in the Cabal library.)+    [] -> do+      -- Emit a warning if there are non-demanded rules.+      unless (null nonDemandedRuleVerts) $+        warn verbosity $+          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)"+                 ]++      -- Run all the demanded rules, in dependency order.+      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)+          -- 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.+            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 ()+  where+    toRuleBinary :: RuleData userOrSystem -> RuleBinary+    toRuleBinary = case scope of+      SUser -> ruleBinary+      SSystem -> id+    clbi = targetCLBI tgtInfo+    mbWorkDir = mbWorkDirLBI lbi+    compAutogenDir = autogenComponentModulesDir lbi clbi+    errorOut e =+      dieWithException verbosity $+        SetupHooksException $+          RulesException e++directRuleDependencyMaybe :: Rule.Dependency -> Maybe RuleId+directRuleDependencyMaybe (RuleDependency dep) = Just $ outputOfRule dep+directRuleDependencyMaybe (FileDependency{}) = Nothing++resolveDependency :: Verbosity -> RuleId -> Map RuleId (RuleData scope) -> Rule.Dependency -> IO Location+resolveDependency verbosity rId allRules = \case+  FileDependency l -> return l+  RuleDependency (RuleOutput{outputOfRule = depId, outputIndex = i}) ->+    case Map.lookup depId allRules of+      Nothing ->+        error $+          unlines $+            [ "Internal error: missing rule dependency."+            , "Rule: " ++ show rId+            , "Dependency: " ++ show depId+            ]+      Just (Rule{results = os}) ->+        let j :: Int+            j = fromIntegral i+         in case listToMaybe $ drop j $ NE.toList os of+              Just o+                | j >= 0 ->+                    return o+              _ ->+                dieWithException verbosity $+                  SetupHooksException $+                    RulesException $+                      InvalidRuleOutputIndex rId depId os i++-- | 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)++-- | Is the file we depend on missing?+missingDep :: Maybe (SymbolicPath CWD (Dir Pkg)) -> Location -> IO Bool+missingDep mbWorkDir loc = not <$> doesFileExist fp+  where+    fp = interpretSymbolicPath mbWorkDir (location loc)++--------------------------------------------------------------------------------+-- Compatibility with HookedBuildInfo.+--+-- NB: assumes that the components in HookedBuildInfo are:+--  - an (optional) main library,+--  - executables.+--+-- No support for named sublibraries, foreign libraries, tests or benchmarks,+-- because the HookedBuildInfo datatype doesn't specify what type of component+-- each component name is (so we assume they are executables).++hookedBuildInfoComponents :: HookedBuildInfo -> Set ComponentName+hookedBuildInfoComponents (mb_mainlib, exes) =+  Set.fromList $+    (case mb_mainlib of Nothing -> id; Just{} -> (CLibName LMainLibName :))+      [CExeName exe_nm | (exe_nm, _) <- exes]++hookedBuildInfoComponentDiff_maybe :: HookedBuildInfo -> ComponentName -> Maybe (IO ComponentDiff)+hookedBuildInfoComponentDiff_maybe (mb_mainlib, exes) comp_nm =+  case comp_nm of+    CLibName lib_nm ->+      case lib_nm of+        LMainLibName -> return . ComponentDiff . CLib . buildInfoLibraryDiff <$> mb_mainlib+        LSubLibName{} -> Nothing+    CExeName exe_nm ->+      let mb_exe = lookup exe_nm exes+       in return . ComponentDiff . CExe . buildInfoExecutableDiff <$> mb_exe+    CFLibName{} -> Nothing+    CTestName{} -> Nothing+    CBenchName{} -> Nothing++buildInfoLibraryDiff :: BuildInfo -> LibraryDiff+buildInfoLibraryDiff bi = emptyLibrary{libBuildInfo = bi}++buildInfoExecutableDiff :: BuildInfo -> ExecutableDiff+buildInfoExecutableDiff bi = emptyExecutable{buildInfo = bi}++--------------------------------------------------------------------------------+-- Instances for serialisation++deriving newtype instance Binary ComponentDiff+deriving newtype instance Structured ComponentDiff++instance Binary PreConfPackageInputs+instance Structured PreConfPackageInputs+instance Binary PreConfPackageOutputs+instance Structured PreConfPackageOutputs++instance Binary PostConfPackageInputs+instance Structured PostConfPackageInputs++instance Binary PreConfComponentInputs+instance Structured PreConfComponentInputs+instance Binary PreConfComponentOutputs+instance Structured PreConfComponentOutputs++instance Binary PreBuildComponentInputs+instance Structured PreBuildComponentInputs++instance Binary PostBuildComponentInputs+instance Structured PostBuildComponentInputs++instance Binary InstallComponentInputs+instance Structured InstallComponentInputs++--------------------------------------------------------------------------------
+ src/Distribution/Simple/SetupHooks/Rule.hs view
@@ -0,0 +1,1140 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module: Distribution.Simple.SetupHooks.Rule+--+-- Internal module that defines fine-grained rules for setup hooks.+-- Users should import 'Distribution.Simple.SetupHooks' instead.+module Distribution.Simple.SetupHooks.Rule+  ( -- * Rules++    -- ** Rule+    Rule+  , RuleData (..)+  , RuleId (..)+  , staticRule+  , dynamicRule++    -- ** Commands+  , RuleCommands (..)+  , Command+  , CommandData (..)+  , runCommand+  , mkCommand+  , Dict (..)++    -- *** Helpers for executing commands+  , RuleCmds+  , RuleDynDepsCmd+  , RuleExecCmd+  , DynDepsCmd (..)+  , DepsRes (..)+  , ruleDepsCmd+  , runRuleDynDepsCmd+  , ruleExecCmd+  , runRuleExecCmd++    -- ** Collections of rules+  , Rules (..)+  , Dependency (..)+  , RuleOutput (..)+  , rules+  , noRules++    -- ** Rule inputs/outputs+  , Location (..)+  , location++    -- ** File/directory monitoring+  , MonitorFilePath (..)+  , MonitorKindFile (..)+  , MonitorKindDir (..)++    -- *** Monadic API for generation of 'ActionId'+  , RulesM+  , RulesT (..)+  , RulesEnv (..)+  , computeRules++    -- * Internals+  , Scope (..)+  , SScope (..)+  , Static (..)+  , RuleBinary+  , ruleBinary+  )+where++import qualified Distribution.Compat.Binary as Binary+import Distribution.Compat.Prelude++import Distribution.ModuleName+  ( ModuleName+  )+import Distribution.Simple.FileMonitor.Types+import Distribution.Types.UnitId+import Distribution.Utils.Path+  ( FileOrDir (..)+  , Pkg+  , RelativePath+  , SymbolicPath+  , getSymbolicPath+  , (</>)+  )+import Distribution.Utils.ShortText+  ( ShortText+  )+import Distribution.Utils.Structured+  ( Structure (..)+  , Structured (..)+  , nominalStructure+  )+import Distribution.Verbosity+  ( Verbosity+  )++import Control.Monad.Fix+  ( MonadFix+  )+import Control.Monad.Trans+  ( MonadIO+  , MonadTrans (..)+  )+import qualified Control.Monad.Trans.Reader as Reader+import qualified Control.Monad.Trans.State as State+#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+  ( empty+  )++import qualified Data.Kind as Hs+import Data.Type.Bool+  ( If+  )+import Data.Type.Equality+  ( (:~~:) (HRefl)+  , type (==)+  )+import GHC.Show+  ( showCommaSpace+  )+import GHC.StaticPtr+import GHC.TypeLits+  ( Symbol+  )+import System.IO.Unsafe+  ( unsafePerformIO+  )+import qualified Type.Reflection as Typeable+  ( SomeTypeRep (..)+  , TypeRep+  , eqTypeRep+  , typeRep+  , typeRepKind+  , withTypeable+  , pattern App+  )++import System.FilePath+  ( normalise+  )++--------------------------------------------------------------------------------++{- Note [Fine-grained hooks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To best understand how the framework of fine-grained build rules+fits into Cabal and the greater Haskell ecosystem, it is helpful to think+that we want build tools (such as cabal-install or HLS) to be able to call+individual build rules on-demand, so that e.g. when a user modifies a .xyz file+the associated preprocessor is re-run.++To do this, we need to perform two different kinds of invocations:++  Query: query the package for the rules that it provides, with their+         dependency information. This allows one to determine when each+         rule should be rerun.++         (For example, if one rule preprocesses *.xyz into *.hs, we need to+         re-run the rule whenever *.xyz is modified.)++  Run: run the relevant action, once one has determined that the rule+       has gone stale.++To do this, any Cabal package with Hooks build-type provides a SetupHooks+module which supports these queries; for example it can be compiled into+a separate executable which can be invoked in the manner described above.+-}++---------+-- Rules++-- | A unique identifier for a t'Rule'.+data RuleId = RuleId+  { ruleNameSpace :: !RulesNameSpace+  , ruleName :: !ShortText+  }+  deriving stock (Show, Eq, Ord, Generic)+  deriving anyclass (Binary, Structured)++data RulesNameSpace = RulesNameSpace+  { rulesUnitId :: !UnitId+  , rulesModuleName :: !ModuleName+  , rulesSrcLoc :: !(Int, Int)+  }+  deriving stock (Show, Eq, Ord, Generic)+  deriving anyclass (Binary, Structured)++-- | Internal function: create a 'RulesNameSpace' from a 'StaticPtrInfo'.+staticPtrNameSpace :: StaticPtrInfo -> RulesNameSpace+staticPtrNameSpace+  StaticPtrInfo+    { spInfoUnitId = unitId+    , spInfoModuleName = modName+    , spInfoSrcLoc = srcLoc+    } =+    RulesNameSpace+      { rulesUnitId = mkUnitId unitId+      , rulesModuleName = fromString modName+      , rulesSrcLoc = srcLoc+      }++-- | 'Rule's are defined with rich types by the package.+--+-- The build system only has a limited view of these; most data consists of+-- opaque 'ByteString's.+--+-- The 'Scope' data-type describes which side of this divide we are on.+data Scope+  = -- | User space (with rich types).+    User+  | -- | Build-system space (manipulation of raw data).+    System++data SScope (scope :: Scope) where+  SUser :: SScope User+  SSystem :: SScope System++type Rule = RuleData User+type RuleBinary = RuleData System++-- | A rule consists of:+--+--  - an action to run to execute the rule,+--  - a description of the rule inputs and outputs.+--+-- Use 'staticRule' or 'dynamicRule' to construct a rule, overriding specific+-- fields, rather than directly using the 'Rule' constructor.+data RuleData (scope :: Scope)+  = -- | Please use the 'staticRule' or 'dynamicRule' smart constructors+    -- instead of this constructor, in order to avoid relying on internal+    -- implementation details.+    Rule+    { ruleCommands :: !(RuleCmds scope)+    -- ^ To run this rule, which t'Command's should we execute?+    , staticDependencies :: ![Dependency]+    -- ^ Static dependencies of this rule.+    , results :: !(NE.NonEmpty Location)+    -- ^ Results of this rule.+    }+  deriving stock (Generic)++deriving stock instance Show (RuleData User)+deriving stock instance Eq (RuleData User)+deriving stock instance Eq (RuleData System)+deriving anyclass instance Binary (RuleData User)+deriving anyclass instance Binary (RuleData System)++-- | Trimmed down 'Show' instance, mostly for error messages.+instance Show RuleBinary where+  show (Rule{staticDependencies = deps, results = reslts, ruleCommands = cmds}) =+    what ++ ": " ++ showDeps deps ++ " --> " ++ show (NE.toList reslts)+    where+      what = case cmds of+        StaticRuleCommand{} -> "Rule"+        DynamicRuleCommands{} -> "Rule (dyn-deps)"+      showDeps :: [Dependency] -> String+      showDeps ds = "[" ++ intercalate ", " (map showDep ds) ++ "]"+      showDep :: Dependency -> String+      showDep = \case+        RuleDependency (RuleOutput{outputOfRule = rId, outputIndex = i}) ->+          "(" ++ show rId ++ ")[" ++ show i ++ "]"+        FileDependency loc -> show loc++-- | A rule with static dependencies.+--+-- Prefer using this smart constructor instead of v'Rule' whenever possible.+staticRule+  :: forall arg+   . Typeable arg+  => Command arg (IO ())+  -> [Dependency]+  -> NE.NonEmpty Location+  -> Rule+staticRule cmd dep res =+  Rule+    { ruleCommands =+        StaticRuleCommand+          { staticRuleCommand = cmd+          , staticRuleArgRep = Typeable.typeRep @arg+          }+    , staticDependencies = dep+    , results = res+    }++-- | A rule with dynamic dependencies.+--+-- Prefer using this smart constructor instead of v'Rule' whenever possible.+dynamicRule+  :: forall depsArg depsRes arg+   . (Typeable depsArg, Typeable depsRes, Typeable arg)+  => StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))+  -> Command depsArg (IO ([Dependency], depsRes))+  -> Command arg (depsRes -> IO ())+  -> [Dependency]+  -> NE.NonEmpty Location+  -> Rule+dynamicRule dict depsCmd action dep res =+  Rule+    { ruleCommands =+        DynamicRuleCommands+          { dynamicRuleInstances = UserStatic dict+          , dynamicDeps = DynDepsCmd{dynDepsCmd = depsCmd}+          , dynamicRuleCommand = action+          , dynamicRuleTypeRep = Typeable.typeRep @(depsArg, depsRes, arg)+          }+    , staticDependencies = dep+    , results = res+    }++-----------------------+-- Rule inputs/outputs++-- | A (fully resolved) location of a dependency or result of a rule,+-- consisting of a base directory and of a file path relative to that base+-- directory path.+--+-- In practice, this will be something like @'Location' dir ('moduleNameSymbolicPath' mod <.> "hs")@,+-- where:+--+--  - for a file dependency, @dir@ is one of the Cabal search directories,+--  - for an output, @dir@ is a directory such as @autogenComponentModulesDir@+--    or @componentBuildDir@.+data Location where+  Location+    :: { locationBaseDir :: !(SymbolicPath Pkg (Dir baseDir))+        -- ^ Base directory.+       , locationRelPath :: !(RelativePath baseDir File)+        -- ^ File path relative to base directory (including file extension).+       }+    -> Location++instance Eq Location where+  Location b1 l1 == Location b2 l2 =+    (getSymbolicPath b1 == getSymbolicPath b2)+      && (getSymbolicPath l1 == getSymbolicPath l2)+instance Ord Location where+  compare (Location b1 l1) (Location b2 l2) =+    compare+      (getSymbolicPath b1, getSymbolicPath l1)+      (getSymbolicPath b2, getSymbolicPath l2)+instance Binary Location where+  put (Location base loc) = put (base, loc)+  get = Location <$> get <*> get+instance Structured Location where+  structure _ =+    Structure+      tr+      0+      (show tr)+      [+        ( "Location"+        ,+          [ nominalStructure $ Proxy @(SymbolicPath Pkg (Dir (Tok "baseDir")))+          , nominalStructure $ Proxy @(RelativePath (Tok "baseDir") File)+          ]+        )+      ]+    where+      tr = Typeable.SomeTypeRep $ Typeable.typeRep @Location++-- | Get a (relative or absolute) un-interpreted path to a 'Location'.+location :: Location -> SymbolicPath Pkg File+location (Location base rel) = base </> rel++instance Show Location where+  showsPrec p (Location base rel) =+    showParen (p > 5) $+      showString (normalise $ getSymbolicPath base)+        . showString " </> "+        . showString (normalise $ getSymbolicPath rel)++-- The reason for splitting it up this way is that some pre-processors don't+-- simply generate one output @.hs@ file from one input file, but have+-- dependencies on other generated files (notably @c2hs@, where building one+-- @.hs@ file may require reading other @.chi@ files, and then compiling the+-- @.hs@ file may require reading a generated @.h@ file).+-- In these cases, the generated files need to embed relative path names to each+-- other (eg the generated @.hs@ file mentions the @.h@ file in the FFI imports).+-- This path must be relative to the base directory where the generated files+-- are located; it cannot be relative to the top level of the build tree because+-- the compilers do not look for @.h@ files relative to there, ie we do not use+-- @-I .@, instead we use @-I dist/build@ (or whatever dist dir has been set+-- by the user).++-- | A dependency of a rule.+data Dependency+  = -- | A dependency on an output of another rule.+    RuleDependency !RuleOutput+  | -- | A direct dependency on a file at a particular location on disk.+    --+    -- This should not be used for files that are generated by other rules;+    -- use 'RuleDependency' instead.+    FileDependency !Location+  deriving stock (Show, Eq, Ord, Generic)+  deriving anyclass (Binary, Structured)++-- | A reference to an output of another rule.+data RuleOutput = RuleOutput+  { outputOfRule :: !RuleId+  -- ^ which rule's outputs are we referring to?+  , outputIndex :: !Word+  -- ^ which particular output of that rule?+  }+  deriving stock (Show, Eq, Ord, Generic)+  deriving anyclass (Binary, Structured)++---------+-- Rules++-- | Monad for constructing rules.+type RulesM a = RulesT IO a++-- | The environment within the monadic API.+data RulesEnv = RulesEnv+  { rulesEnvVerbosity :: !Verbosity+  , rulesEnvNameSpace :: !RulesNameSpace+  }++-- | Monad transformer for defining rules. Usually wraps the 'IO' monad,+-- allowing @IO@ actions to be performed using @liftIO@.+newtype RulesT m a = RulesT+  { runRulesT+      :: Reader.ReaderT+          RulesEnv+          ( State.StateT+              (Map RuleId Rule)+              (Writer.WriterT [MonitorFilePath] m)+          )+          a+  }+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadFix)++instance MonadTrans RulesT where+  lift = RulesT . lift . lift . lift++-- | A collection of t'Rule's.+--+-- Use the 'rules' smart constructor instead of directly using the v'Rules'+-- constructor.+--+--   - Rules are registered using 'registerRule',+--   - Monitored files or directories are declared using 'addRuleMonitors';+--     a change in these will trigger the recomputation of all rules.+--+-- The @env@ type parameter represents an extra argument, which usually+-- consists of information known to Cabal such as 'LocalBuildInfo' and+-- 'ComponentLocalBuildInfo'.+newtype Rules env = Rules {runRules :: env -> RulesM ()}++-- | __Warning__: this 'Semigroup' instance is not commutative.+instance Semigroup (Rules env) where+  (Rules rs1) <> (Rules rs2) =+    Rules $ \inputs -> do+      y1 <- rs1 inputs+      y2 <- rs2 inputs+      return $ y1 <> y2++instance Monoid (Rules env) where+  mempty = Rules $ const noRules++-- | An empty collection of rules.+noRules :: RulesM ()+noRules = return ()++-- | Construct a collection of rules with a given label.+--+-- A label for the rules can be constructed using the @static@ keyword,+-- using the @StaticPointers@ extension.+-- NB: separate calls to 'rules' should have different labels.+--+-- Example usage:+--+-- > myRules :: Rules env+-- > myRules = rules (static ()) $ \ env -> do { .. } -- use the monadic API here+rules+  :: StaticPtr label+  -- ^ unique label for this collection of rules+  -> (env -> RulesM ())+  -- ^ the computation of rules+  -> Rules env+rules label = rulesInNameSpace (staticPtrNameSpace $ staticPtrInfo label)++-- | Internal function to create a collection of rules.+--+-- API users should go through the 'rules' function instead.+rulesInNameSpace+  :: RulesNameSpace+  -- ^ rule namespace+  -> (env -> RulesM ())+  -- ^ the computation of rules+  -> Rules env+rulesInNameSpace nameSpace f =+  Rules $ \env -> RulesT $ do+    Reader.withReaderT (\rulesEnv -> rulesEnv{rulesEnvNameSpace = nameSpace}) $+      runRulesT $+        f env++-- | Internal function: run the monadic 'Rules' computations in order+-- to obtain all the 'Rule's with their 'RuleId's.+computeRules+  :: Verbosity+  -> env+  -> Rules env+  -> IO (Map RuleId Rule, [MonitorFilePath])+computeRules verbosity inputs (Rules rs) = do+  -- Bogus namespace to start with. This will be the first thing+  -- to be set when users use the 'rules' smart constructor.+  let noNameSpace =+        RulesNameSpace+          { rulesUnitId = mkUnitId ""+          , rulesModuleName = fromString ""+          , rulesSrcLoc = (0, 0)+          }+      env0 =+        RulesEnv+          { rulesEnvVerbosity = verbosity+          , rulesEnvNameSpace = noNameSpace+          }+  Writer.runWriterT $+    (`State.execStateT` Map.empty) $+      (`Reader.runReaderT` env0) $+        runRulesT $+          rs inputs++------------+-- Commands++-- | A static pointer (in user scope) or its key (in system scope).+data family Static (scope :: Scope) :: Hs.Type -> Hs.Type++newtype instance Static User fnTy = UserStatic {userStaticPtr :: StaticPtr fnTy}+newtype instance Static System fnTy = SystemStatic {userStaticKey :: StaticKey}+  deriving newtype (Eq, Ord, Show, Binary)++systemStatic :: Static User fnTy -> Static System fnTy+systemStatic (UserStatic ptr) = SystemStatic (staticKey ptr)++instance Show (Static User fnTy) where+  showsPrec p ptr = showsPrec p (systemStatic ptr)+instance Eq (Static User fnTy) where+  (==) = (==) `on` systemStatic+instance Ord (Static User fnTy) where+  compare = compare `on` systemStatic+instance Binary (Static User fnTy) where+  put = put . systemStatic+  get = do+    ptrKey <- get @StaticKey+    case unsafePerformIO $ unsafeLookupStaticPtr ptrKey of+      Just ptr -> return $ UserStatic ptr+      Nothing ->+        fail $+          unlines+            [ "Failed to look up static pointer key for action."+            , "NB: Binary instances for 'User' types cannot be used in external executables."+            ]++-- | A command consists of a statically-known action together with a+-- (possibly dynamic) argument to that action.+--+-- For example, the action can consist of running an executable+-- (such as @happy@ or @c2hs@), while the argument consists of the variable+-- component of the command, e.g. the specific file to run @happy@ on.+type Command = CommandData User++-- | Internal datatype used for commands, both for the Hooks API ('Command')+-- and for the build system.+data CommandData (scope :: Scope) (arg :: Hs.Type) (res :: Hs.Type) = Command+  { actionPtr :: !(Static scope (arg -> res))+  -- ^ The (statically-known) action to execute.+  , actionArg :: !(ScopedArgument scope arg)+  -- ^ The (possibly dynamic) argument to pass to the action.+  , cmdInstances :: !(Static scope (Dict (Binary arg, Show arg)))+  -- ^ Static evidence that the argument can be serialised and deserialised.+  }++-- | Construct a command.+--+-- Prefer using this smart constructor instead of v'Command' whenever possible.+mkCommand+  :: forall arg res+   . StaticPtr (Dict (Binary arg, Show arg))+  -> StaticPtr (arg -> res)+  -> arg+  -> Command arg res+mkCommand dict action arg =+  Command+    { actionPtr = UserStatic action+    , actionArg = ScopedArgument arg+    , cmdInstances = UserStatic dict+    }++-- | Run a 'Command'.+runCommand :: Command args res -> res+runCommand (Command{actionPtr = UserStatic ptr, actionArg = ScopedArgument arg}) =+  deRefStaticPtr ptr arg++-- | Commands to execute a rule:+--+--   - for a rule with static dependencies, a single command,+--   - for a rule with dynamic dependencies, a command for computing dynamic+--     dependencies, and a command for executing the rule.+data+  RuleCommands+    (scope :: Scope)+    (deps :: Scope -> Hs.Type -> Hs.Type -> Hs.Type)+    (ruleCmd :: Scope -> Hs.Type -> Hs.Type -> Hs.Type)+  where+  -- | A rule with statically-known dependencies.+  StaticRuleCommand+    :: forall arg deps ruleCmd scope+     . If+        (scope == System)+        (arg ~ LBS.ByteString)+        (() :: Hs.Constraint)+    => { staticRuleCommand :: !(ruleCmd scope arg (IO ()))+        -- ^ The command to execute the rule.+       , staticRuleArgRep :: !(If (scope == System) Typeable.SomeTypeRep (Typeable.TypeRep arg))+        -- ^ A 'TypeRep' for 'arg'.+       }+    -> RuleCommands scope deps ruleCmd+  DynamicRuleCommands+    :: forall depsArg depsRes arg deps ruleCmd scope+     . If+        (scope == System)+        (depsArg ~ LBS.ByteString, depsRes ~ LBS.ByteString, arg ~ LBS.ByteString)+        (() :: Hs.Constraint)+    => { dynamicRuleInstances :: !(Static scope (Dict (Binary depsRes, Show depsRes, Eq depsRes)))+        -- ^ A rule with dynamic dependencies, which consists of two parts:+        --+        --  - a dynamic dependency computation, that returns additional edges to+        --    be added to the build graph together with an additional piece of data,+        --  - the command to execute the rule itself, which receives the additional+        --    piece of data returned by the dependency computation.+       , -- \^ Static evidence used for serialisation, in order to pass the result+         -- of the dependency computation to the main rule action.+         dynamicDeps :: !(deps scope depsArg depsRes)+        -- ^ A dynamic dependency computation. The resulting dependencies+        -- will be injected into the build graph, and the result of the computation+        -- will be passed on to the command that executes the rule.+       , dynamicRuleCommand :: !(ruleCmd scope arg (depsRes -> IO ()))+        -- ^ The command to execute the rule. It will receive the result+        -- of the dynamic dependency computation.+       , dynamicRuleTypeRep+          :: !( If+                  (scope == System)+                  Typeable.SomeTypeRep+                  (Typeable.TypeRep (depsArg, depsRes, arg))+              )+        -- ^ A 'TypeRep' for the triple @(depsArg,depsRes,arg)@.+       }+    -> RuleCommands scope deps ruleCmd++{- Note [Hooks Binary instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Hooks API is strongly typed: users can declare rule commands with varying+types, e.g.++  staticRule+  :: forall arg+   . Typeable arg+  => Command arg (IO ())+  -> [Dependency]+  -> NE.NonEmpty Location+  -> Rule++allows a user to declare a 'Command' that receives an argument of type 'arg'+of their choosing.++This all makes sense within the Hooks API, but when communicating with an+external build system (such as cabal-install or HLS), these arguments are+treated as opaque blobs of data (in particular if the Hooks are compiled into+a separate executable, then the static pointers that contain the relevant+instances for these user-chosen types can only be dereferenced from within that+executable, and not on the side of the build system).++This means that, to enable Hooks to be communicated between the package and the+build system, we need:++  1. Two representations of rules: one for the package author using the Hooks API,+     and one for the build system.+  2. Compatibility in the 'Binary' instances for these two types. One needs to be+     able to serialise a 'User'-side 'Rule', and de-serialise it on the build system+     into a 'System'-side 'Rule' which contains some opaque bits of data, and+     vice-versa.++(1) is achieved using the 'Scope' parameter to the 'RuleData' datatype.+@Rule = RuleData User@ is the API-side representation, whereas+@RuleBinary = RuleData System@ is the build-system-side representation.++For (2), note that when we serialise a value of known type and known size, e.g.+an 'Int64', we are nevertheless required to also serialise its size. This is because,+on the build-system side, we don't have access to any of the types, and thus don't know+how much to read in order to reconstruct the associated opaque 'ByteString'.+To ensure we always serialise/deserialise including the length of the data,+the 'ScopedArgument' newtype is used, with a custom 'Binary' instance that always+includes the length. We use this newtype:++  - in the definition of 'CommandData', for arguments to rules,+  - in the definition of 'DepsRes', for the result of dynamic dependency computations.+-}++newtype ScopedArgument (scope :: Scope) arg = ScopedArgument {getArg :: arg}+  deriving newtype (Eq, Ord, Show)++-- | Serialise/deserialise, always including the length of the payload.+instance Binary arg => Binary (ScopedArgument User arg) where+  put (ScopedArgument arg) = put @LBS.ByteString (Binary.encode arg)+  get = do+    dat <- get @LBS.ByteString+    case Binary.decodeOrFail dat of+      Left (_, _, err) -> fail err+      Right (_, _, res) -> return $ ScopedArgument res++-- | Serialise and deserialise a raw ByteString, leaving it untouched.+instance arg ~ LBS.ByteString => Binary (ScopedArgument System arg) where+  put (ScopedArgument arg) = put arg+  get = ScopedArgument <$> get++-- | A placeholder for a command that has been omitted, e.g. when we don't+-- care about serialising/deserialising one particular command in a datatype.+data NoCmd (scope :: Scope) arg res = CmdOmitted+  deriving stock (Generic, Eq, Ord, Show)+  deriving anyclass (Binary)++-- | A dynamic dependency command.+newtype DynDepsCmd scope depsArg depsRes = DynDepsCmd+  { dynDepsCmd+      :: CommandData scope depsArg (IO ([Dependency], depsRes))+  }++deriving newtype instance Show (DynDepsCmd User depsArg depsRes)+deriving newtype instance Eq (DynDepsCmd User depsArg depsRes)+deriving newtype instance Binary (DynDepsCmd User depsArg depsRes)+deriving newtype instance+  (arg ~ LBS.ByteString, depsRes ~ LBS.ByteString)+  => Eq (DynDepsCmd System arg depsRes)+deriving newtype instance+  (arg ~ LBS.ByteString, depsRes ~ LBS.ByteString)+  => Binary (DynDepsCmd System arg depsRes)++-- | The result of a dynamic dependency computation.+newtype DepsRes (scope :: Scope) depsArg depsRes = DepsRes+  { depsRes+      :: ScopedArgument scope depsRes -- See Note [Hooks Binary instances]+  }+  deriving newtype (Show, Eq, Ord)++deriving newtype instance+  Binary (ScopedArgument scope depsRes)+  => Binary (DepsRes scope depsArg depsRes)++-- | Both the rule command and the (optional) dynamic dependency command.+type RuleCmds scope = RuleCommands scope DynDepsCmd CommandData++-- | Only the (optional) dynamic dependency command.+type RuleDynDepsCmd scope = RuleCommands scope DynDepsCmd NoCmd++-- | The rule command together with the result of the (optional) dynamic+-- dependency computation.+type RuleExecCmd scope = RuleCommands scope DepsRes CommandData++-- | Project out the (optional) dependency computation command, so that+-- it can be serialised without serialising anything else.+ruleDepsCmd :: RuleCmds scope -> RuleDynDepsCmd scope+ruleDepsCmd = \case+  StaticRuleCommand+    { staticRuleCommand = _ :: CommandData scope args (IO ())+    , staticRuleArgRep = tr+    } ->+      StaticRuleCommand+        { staticRuleCommand = CmdOmitted :: NoCmd scope args (IO ())+        , staticRuleArgRep = tr+        }+  DynamicRuleCommands+    { dynamicRuleCommand = _ :: CommandData scope args (depsRes -> IO ())+    , dynamicRuleInstances = instsPtr+    , dynamicDeps = deps+    , dynamicRuleTypeRep = tr+    } ->+      DynamicRuleCommands+        { dynamicRuleInstances = instsPtr+        , dynamicDeps = deps+        , dynamicRuleCommand = CmdOmitted :: NoCmd scope args (depsRes -> IO ())+        , dynamicRuleTypeRep = tr+        }++-- | Obtain the (optional) 'IO' action that computes dynamic dependencies.+runRuleDynDepsCmd :: RuleDynDepsCmd User -> Maybe (IO ([Dependency], LBS.ByteString))+runRuleDynDepsCmd = \case+  StaticRuleCommand{} -> Nothing+  DynamicRuleCommands+    { dynamicRuleInstances = UserStatic instsPtr+    , dynamicDeps = DynDepsCmd{dynDepsCmd = depsCmd}+    }+      | Dict <- deRefStaticPtr instsPtr ->+          Just $ do+            (deps, dynDeps) <- runCommand depsCmd+            -- See Note [Hooks Binary instances]+            return $ (deps, Binary.encode $ ScopedArgument @User dynDeps)++-- | Project out the command for running the rule, passing in the result of+-- the dependency computation if there was one.+ruleExecCmd :: SScope scope -> RuleCmds scope -> Maybe LBS.ByteString -> RuleExecCmd scope+ruleExecCmd+  _+  StaticRuleCommand{staticRuleCommand = cmd, staticRuleArgRep = tr}+  _ =+    StaticRuleCommand{staticRuleCommand = cmd, staticRuleArgRep = tr}+ruleExecCmd+  scope+  DynamicRuleCommands+    { dynamicRuleInstances = instsPtr+    , dynamicRuleCommand = cmd :: CommandData scope arg (depsRes -> IO ())+    , dynamicDeps = _ :: DynDepsCmd scope depsArg depsRes+    , dynamicRuleTypeRep = tr+    }+  mbDepsResBinary =+    case mbDepsResBinary of+      Nothing ->+        error $+          unlines+            [ "Missing ByteString argument in 'ruleExecCmd'."+            , "Run 'runRuleDynDepsCmd' on the rule to obtain this data."+            ]+      Just depsResBinary ->+        case scope of+          SUser+            | Dict <- deRefStaticPtr (userStaticPtr instsPtr) ->+                DynamicRuleCommands+                  { dynamicRuleInstances = instsPtr+                  , dynamicRuleCommand = cmd+                  , dynamicDeps = Binary.decode depsResBinary :: DepsRes User depsArg depsRes+                  , dynamicRuleTypeRep = tr+                  }+          SSystem ->+            DynamicRuleCommands+              { dynamicRuleInstances = instsPtr+              , dynamicRuleCommand = cmd+              , dynamicDeps = DepsRes $ ScopedArgument depsResBinary+              , dynamicRuleTypeRep = tr+              }++-- | Obtain the 'IO' action that executes a rule.+runRuleExecCmd :: RuleExecCmd User -> IO ()+runRuleExecCmd = \case+  StaticRuleCommand{staticRuleCommand = cmd} -> runCommand cmd+  DynamicRuleCommands+    { dynamicDeps = DepsRes (ScopedArgument{getArg = res})+    , dynamicRuleCommand = cmd+    } ->+      runCommand cmd res++--------------------------------------------------------------------------------+-- Instances++-- | A wrapper used to pass evidence of a constraint as an explicit value.+data Dict c where+  Dict :: c => Dict c++instance Show (CommandData User arg res) where+  showsPrec prec (Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = insts})+    | Dict <- deRefStaticPtr (userStaticPtr insts) =+        showParen (prec >= 11) $+          showString "Command {"+            . showString "actionPtrKey = "+            . shows cmdPtr+            . showCommaSpace+            . showString "actionArg = "+            . shows arg+            . showString "}"++instance Eq (CommandData User arg res) where+  Command{actionPtr = cmdPtr1, actionArg = arg1, cmdInstances = insts1}+    == Command{actionPtr = cmdPtr2, actionArg = arg2, cmdInstances = insts2}+      | cmdPtr1 == cmdPtr2+      , insts1 == insts2+      , Dict <- deRefStaticPtr (userStaticPtr insts1) =+          Binary.encode arg1 == Binary.encode arg2+      | otherwise =+          False+instance arg ~ LBS.ByteString => Eq (CommandData System arg res) where+  Command a1 b1 c1 == Command a2 b2 c2 =+    a1 == a2 && b1 == b2 && c1 == c2++instance Binary (CommandData User arg res) where+  put (Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = insts})+    | Dict <- deRefStaticPtr (userStaticPtr insts) =+        do+          put cmdPtr+          put insts+          put arg+  get = do+    cmdPtr <- get+    instsPtr <- get+    case deRefStaticPtr @(Dict (Binary arg, Show arg)) $ userStaticPtr instsPtr of+      Dict -> do+        arg <- get+        return $+          Command+            { actionPtr = cmdPtr+            , actionArg = arg+            , cmdInstances = instsPtr+            }+instance arg ~ LBS.ByteString => Binary (CommandData System arg res) where+  put (Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = insts}) =+    do+      put cmdPtr+      put insts+      put arg+  get = do+    cmdKey <- get+    instsKey <- get+    arg <- get+    return $ Command{actionPtr = cmdKey, actionArg = arg, cmdInstances = instsKey}++instance+  ( forall arg res. Show (ruleCmd User arg res)+  , forall depsArg depsRes. Show depsRes => Show (deps User depsArg depsRes)+  )+  => Show (RuleCommands User deps ruleCmd)+  where+  showsPrec prec (StaticRuleCommand{staticRuleCommand = cmd}) =+    showParen (prec >= 11) $+      showString "StaticRuleCommand {"+        . showString "staticRuleCommand = "+        . shows cmd+        . showString "}"+  showsPrec+    prec+    ( DynamicRuleCommands+        { dynamicDeps = deps+        , dynamicRuleCommand = cmd+        , dynamicRuleInstances = UserStatic instsPtr+        }+      )+      | Dict <- deRefStaticPtr instsPtr =+          showParen (prec >= 11) $+            showString "DynamicRuleCommands {"+              . showString "dynamicDeps = "+              . shows deps+              . showCommaSpace+              . showString "dynamicRuleCommand = "+              . shows cmd+              . showString "}"++instance+  ( forall arg res. Eq (ruleCmd User arg res)+  , forall depsArg depsRes. Eq depsRes => Eq (deps User depsArg depsRes)+  )+  => Eq (RuleCommands User deps ruleCmd)+  where+  StaticRuleCommand{staticRuleCommand = ruleCmd1 :: ruleCmd User arg1 (IO ()), staticRuleArgRep = tr1}+    == StaticRuleCommand{staticRuleCommand = ruleCmd2 :: ruleCmd User arg2 (IO ()), staticRuleArgRep = tr2}+      | Just HRefl <- Typeable.eqTypeRep tr1 tr2 =+          ruleCmd1 == ruleCmd2+  DynamicRuleCommands+    { dynamicDeps = depsCmd1 :: deps User depsArg1 depsRes1+    , dynamicRuleCommand = ruleCmd1 :: ruleCmd User arg1 (depsRes1 -> IO ())+    , dynamicRuleInstances = UserStatic instsPtr1+    , dynamicRuleTypeRep = tr1+    }+    == DynamicRuleCommands+      { dynamicDeps = depsCmd2 :: deps User depsArg2 depsRes2+      , dynamicRuleCommand = ruleCmd2 :: ruleCmd User arg2 (depsRes2 -> IO ())+      , dynamicRuleInstances = UserStatic instsPtr2+      , dynamicRuleTypeRep = tr2+      }+      | Just HRefl <- Typeable.eqTypeRep tr1 tr2+      , Dict <- deRefStaticPtr instsPtr1 =+          depsCmd1 == depsCmd2+            && ruleCmd1 == ruleCmd2+            && staticKey instsPtr1 == staticKey instsPtr2+  _ == _ = False++instance+  ( forall res. Eq (ruleCmd System LBS.ByteString res)+  , Eq (deps System LBS.ByteString LBS.ByteString)+  )+  => Eq (RuleCommands System deps ruleCmd)+  where+  StaticRuleCommand c1 d1 == StaticRuleCommand c2 d2 = c1 == c2 && d1 == d2+  DynamicRuleCommands a1 b1 c1 d1 == DynamicRuleCommands a2 b2 c2 d2 =+    a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2+  _ == _ = False++instance+  ( forall arg res. Binary (ruleCmd User arg res)+  , forall depsArg depsRes. Binary depsRes => Binary (deps User depsArg depsRes)+  )+  => Binary (RuleCommands User deps ruleCmd)+  where+  put = \case+    StaticRuleCommand+      { staticRuleCommand = ruleCmd :: ruleCmd User arg (IO ())+      , staticRuleArgRep = tr+      } -> do+        put @Word 0+        put (Typeable.SomeTypeRep tr)+        put ruleCmd+    DynamicRuleCommands+      { dynamicDeps = deps :: deps User depsArg depsRes+      , dynamicRuleCommand = ruleCmd :: ruleCmd User arg (depsRes -> IO ())+      , dynamicRuleInstances = instsPtr+      , dynamicRuleTypeRep = tr+      } | Dict <- deRefStaticPtr (userStaticPtr instsPtr) ->+        do+          put @Word 1+          put (Typeable.SomeTypeRep tr)+          put instsPtr+          put ruleCmd+          put deps+  get = do+    tag <- get @Word+    case tag of+      0 -> do+        Typeable.SomeTypeRep (trArg :: Typeable.TypeRep arg) <- get+        if+            | Just HRefl <- Typeable.eqTypeRep (Typeable.typeRepKind trArg) (Typeable.typeRep @Hs.Type) ->+                do+                  ruleCmd <- get @(ruleCmd User arg (IO ()))+                  return $+                    Typeable.withTypeable trArg $+                      StaticRuleCommand+                        { staticRuleCommand = ruleCmd+                        , staticRuleArgRep = trArg+                        }+            | otherwise ->+                error "internal error when decoding static rule command"+      _ -> do+        Typeable.SomeTypeRep (tr :: Typeable.TypeRep ty) <- get+        case tr of+          Typeable.App+            ( Typeable.App+                (Typeable.App (tup3Tr :: Typeable.TypeRep tup3) (trDepsArg :: Typeable.TypeRep depsArg))+                (trDepsRes :: Typeable.TypeRep depsRes)+              )+            (trArg :: Typeable.TypeRep arg)+              | Just HRefl <- Typeable.eqTypeRep tup3Tr (Typeable.typeRep @(,,)) -> do+                  instsPtr <- get+                  case deRefStaticPtr $ userStaticPtr instsPtr of+                    (Dict :: Dict (Binary depsRes, Show depsRes, Eq depsRes)) ->+                      do+                        ruleCmd <- get @(ruleCmd User arg (depsRes -> IO ()))+                        deps <- get @(deps User depsArg depsRes)+                        return $+                          Typeable.withTypeable trDepsArg $+                            Typeable.withTypeable trDepsRes $+                              Typeable.withTypeable trArg $+                                DynamicRuleCommands+                                  { dynamicDeps = deps+                                  , dynamicRuleCommand = ruleCmd+                                  , dynamicRuleInstances = instsPtr+                                  , dynamicRuleTypeRep = tr+                                  }+          _ -> error "internal error when decoding dynamic rule commands"++-- | A token constructor used to define 'Structured' instances on types+-- that involve existential quantification.+data family Tok (arg :: Symbol) :: k++instance+  ( forall res. Binary (ruleCmd System LBS.ByteString res)+  , Binary (deps System LBS.ByteString LBS.ByteString)+  )+  => Binary (RuleCommands System deps ruleCmd)+  where+  put = \case+    StaticRuleCommand{staticRuleCommand = ruleCmd, staticRuleArgRep = sTr} -> do+      put @Word 0+      put sTr+      put ruleCmd+    DynamicRuleCommands+      { dynamicDeps = deps+      , dynamicRuleCommand = ruleCmd+      , dynamicRuleInstances = instsKey+      , dynamicRuleTypeRep = sTr+      } ->+        do+          put @Word 1+          put sTr+          put instsKey+          put ruleCmd+          put deps+  get = do+    tag <- get @Word+    case tag of+      0 -> do+        sTr <- get @Typeable.SomeTypeRep+        ruleCmd <- get+        return $+          StaticRuleCommand+            { staticRuleCommand = ruleCmd+            , staticRuleArgRep = sTr+            }+      _ -> do+        sTr <- get @Typeable.SomeTypeRep+        instsKey <- get+        ruleCmd <- get+        deps <- get+        return $+          DynamicRuleCommands+            { dynamicDeps = deps+            , dynamicRuleCommand = ruleCmd+            , dynamicRuleInstances = instsKey+            , dynamicRuleTypeRep = sTr+            }++--------------------------------------------------------------------------------+-- Showing rules++ruleBinary :: Rule -> RuleBinary+ruleBinary = Binary.decode . Binary.encode
src/Distribution/Simple/ShowBuildInfo.hs view
@@ -1,8 +1,11 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+ -- | -- This module defines a simple JSON-based format for exporting basic -- information about a Cabal package and the compiler configuration Cabal -- would use to build it. This can be produced with the--- @cabal new-show-build-info@ command.+-- @cabal build --enable-build-info@ command. -- -- -- This format is intended for consumption by external tooling and should@@ -14,7 +17,7 @@ -- Below is an example of the output this module produces, -- -- @--- { "cabal-version": "1.23.0.0",+-- { "cabal-lib-version": "1.23.0.0", --   "compiler": { --     "flavour": "GHC", --     "compiler-id": "ghc-7.10.2",@@ -34,7 +37,10 @@ -- } -- @ ----- The @cabal-version@ property provides the version of the Cabal library+-- The output format needs to be validated against 'doc/json-schemas/build-info.schema.json'.+-- If the format changes, update the schema as well!+--+-- The @cabal-lib-version@ property provides the version of the Cabal library -- which generated the output. The @compiler@ property gives some basic -- information about the compiler Cabal would use to compile the package. --@@ -52,95 +58,138 @@ -- * @src-files@: any other Haskell sources needed by the component -- -- Note: At the moment this is only supported when using the GHC compiler.---+module Distribution.Simple.ShowBuildInfo+  ( mkBuildInfo+  , mkBuildInfo'+  , mkCompilerInfo+  , mkComponentInfo+  ) where -module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where+import System.FilePath  import Distribution.Compat.Prelude import Prelude () -import qualified Distribution.Simple.GHC   as GHC+import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.Program.GHC as GHC -import Distribution.PackageDescription import Distribution.Compiler-import Distribution.Verbosity-import Distribution.Simple.Compiler+import Distribution.PackageDescription+import Distribution.Pretty+import Distribution.Simple.Compiler (Compiler, compilerFlavor, showCompilerId) import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program-import Distribution.Simple.Setup+import Distribution.Simple.Setup.Build (BuildFlags) import Distribution.Simple.Utils (cabalVersion)-import Distribution.Simple.Utils.Json-import Distribution.Types.TargetInfo import Distribution.Text-import Distribution.Pretty+import Distribution.Types.TargetInfo+import Distribution.Utils.Json import Distribution.Utils.Path+import Distribution.Verbosity  -- | Construct a JSON document describing the build information for a -- package. mkBuildInfo-  :: PackageDescription  -- ^ Mostly information from the .cabal file-  -> LocalBuildInfo      -- ^ Configuration information-  -> BuildFlags          -- ^ Flags that the user passed to build+  :: AbsolutePath (Dir Pkg)+  -- ^ The source directory of the package+  -> PackageDescription+  -- ^ Mostly information from the .cabal file+  -> LocalBuildInfo+  -- ^ Configuration information+  -> BuildFlags+  -- ^ Flags that the user passed to build+  -> (ConfiguredProgram, Compiler)+  -- ^ Compiler information.+  -- Needs to be passed explicitly, as we can't extract that information here+  -- without some partial function.   -> [TargetInfo]-  -> Json-mkBuildInfo pkg_descr lbi _flags targetsToBuild = info+  -> ([String], Json)+  -- ^ Json representation of buildinfo alongside generated warnings+mkBuildInfo wdir pkg_descr lbi _flags compilerInfo targetsToBuild = (warnings, JsonObject buildInfoFields)   where-    targetToNameAndLBI target =-      (componentLocalName $ targetCLBI target, targetCLBI target)-    componentsToBuild = map targetToNameAndLBI targetsToBuild-    (.=) :: String -> Json -> (String, Json)-    k .= v = (k, v)--    info = JsonObject-      [ "cabal-version" .= JsonString (display cabalVersion)-      , "compiler"      .= mkCompilerInfo-      , "components"    .= JsonArray (map mkComponentInfo componentsToBuild)-      ]+    buildInfoFields = mkBuildInfo' (uncurry mkCompilerInfo compilerInfo) componentInfos+    componentInfosWithWarnings = map (mkComponentInfo wdir pkg_descr lbi . targetCLBI) targetsToBuild+    componentInfos = map snd componentInfosWithWarnings+    warnings = concatMap fst componentInfosWithWarnings -    mkCompilerInfo = JsonObject-      [ "flavour"     .= JsonString (prettyShow $ compilerFlavor $ compiler lbi)-      , "compiler-id" .= JsonString (showCompilerId $ compiler lbi)-      , "path"        .= path-      ]-      where-        path = maybe JsonNull (JsonString . programPath)-               $ (flavorToProgram . compilerFlavor $ compiler lbi)-               >>= flip lookupProgram (withPrograms lbi)+-- | A variant of 'mkBuildInfo' if you need to call 'mkCompilerInfo' and+-- 'mkComponentInfo' yourself.+--+-- If you change the format or any name in the output json, don't forget to update+-- the schema at @\/doc\/json-schemas\/build-info.schema.json@ and the docs of+-- @--enable-build-info@\/@--disable-build-info@.+mkBuildInfo'+  :: Json+  -- ^ The 'Json' from 'mkCompilerInfo'+  -> [Json]+  -- ^ The 'Json' from 'mkComponentInfo'+  -> [(String, Json)]+mkBuildInfo' compilerInfo componentInfos =+  [ "cabal-lib-version" .= JsonString (display cabalVersion)+  , "compiler" .= compilerInfo+  , "components" .= JsonArray componentInfos+  ] -        flavorToProgram :: CompilerFlavor -> Maybe Program-        flavorToProgram GHC   = Just ghcProgram-        flavorToProgram GHCJS = Just ghcjsProgram-        flavorToProgram UHC   = Just uhcProgram-        flavorToProgram JHC   = Just jhcProgram-        flavorToProgram _     = Nothing+mkCompilerInfo :: ConfiguredProgram -> Compiler -> Json+mkCompilerInfo compilerProgram compilerInfo =+  JsonObject+    [ "flavour" .= JsonString (prettyShow $ compilerFlavor compilerInfo)+    , "compiler-id" .= JsonString (showCompilerId compilerInfo)+    , "path" .= JsonString (programPath compilerProgram)+    ] -    mkComponentInfo (name, clbi) = JsonObject-      [ "type"          .= JsonString compType-      , "name"          .= JsonString (prettyShow name)-      , "unit-id"       .= JsonString (prettyShow $ componentUnitId clbi)-      , "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi)-      , "modules"       .= JsonArray (map (JsonString . display) modules)-      , "src-files"     .= JsonArray (map JsonString sourceFiles)-      , "src-dirs"      .= JsonArray (map JsonString $ map getSymbolicPath $ hsSourceDirs bi)+mkComponentInfo :: AbsolutePath (Dir Pkg) -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> ([String], Json)+mkComponentInfo wdir pkg_descr lbi clbi =+  ( warnings+  , JsonObject $+      [ "type" .= JsonString compType+      , "name" .= JsonString (prettyShow name)+      , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi)+      , "compiler-args" .= JsonArray (map JsonString compilerArgs)+      , "modules" .= JsonArray (map (JsonString . display) modules)+      , "src-files" .= JsonArray (map (JsonString . getSymbolicPath) sourceFiles)+      , "hs-src-dirs" .= JsonArray (map (JsonString . prettyShow) $ hsSourceDirs bi)+      , "src-dir" .= JsonString (addTrailingPathSeparator (getAbsolutePath wdir))       ]-      where-        bi = componentBuildInfo comp-        comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name-        compType = case comp of-          CLib _   -> "lib"-          CExe _   -> "exe"-          CTest _  -> "test"-          CBench _ -> "bench"-          CFLib _  -> "flib"-        modules = case comp of-          CLib lib -> explicitLibModules lib-          CExe exe -> exeModules exe-          _        -> []-        sourceFiles = case comp of-          CLib _   -> []-          CExe exe -> [modulePath exe]-          _        -> []+        <> cabalFile+  )+  where+    (warnings, compilerArgs) = getCompilerArgs bi lbi clbi+    name = componentLocalName clbi+    bi = componentBuildInfo comp+    -- If this error happens, a cabal invariant has been violated+    comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name+    compType = case comp of+      CLib _ -> "lib"+      CExe _ -> "exe"+      CTest _ -> "test"+      CBench _ -> "bench"+      CFLib _ -> "flib"+    modules = case comp of+      CLib lib -> explicitLibModules lib+      CExe exe -> exeModules exe+      CTest test ->+        case testInterface test of+          TestSuiteExeV10 _ _ -> []+          TestSuiteLibV09 _ modName -> [modName]+          TestSuiteUnsupported _ -> []+      CBench bench -> benchmarkModules bench+      CFLib flib -> foreignLibModules flib+    sourceFiles = case comp of+      CLib _ -> []+      CExe exe -> [modulePath exe]+      CTest test ->+        case testInterface test of+          TestSuiteExeV10 _ fp -> [fp]+          TestSuiteLibV09 _ _ -> []+          TestSuiteUnsupported _ -> []+      CBench bench -> case benchmarkInterface bench of+        BenchmarkExeV10 _ fp -> [fp]+        BenchmarkUnsupported _ -> []+      CFLib _ -> []+    cabalFile+      | Just fp <- pkgDescrFile lbi = [("cabal-file", JsonString $ getSymbolicPath fp)]+      | otherwise = []  -- | Get the command-line arguments that would be passed -- to the compiler to build the given component.@@ -148,15 +197,23 @@   :: BuildInfo   -> LocalBuildInfo   -> ComponentLocalBuildInfo-  -> [String]+  -> ([String], [String]) getCompilerArgs bi lbi clbi =   case compilerFlavor $ compiler lbi of-      GHC   -> ghc-      GHCJS -> ghc-      c     -> error $ "ShowBuildInfo.getCompilerArgs: Don't know how to get "++-                       "build arguments for compiler "++show c+    GHC -> ([], ghcArgs)+    GHCJS -> ([], ghcArgs)+    c ->+      (+        [ "ShowBuildInfo.getCompilerArgs: Don't know how to get build "+            ++ " arguments for compiler "+            ++ show c+        ]+      , []+      )   where     -- This is absolutely awful-    ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts-      where-        baseOpts = GHC.componentGhcOptions normal lbi bi clbi (buildDir lbi)+    ghcArgs =+      GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts+    baseOpts =+      GHC.componentGhcOptions normal lbi bi clbi $+        buildDir lbi
src/Distribution/Simple/SrcDist.hs view
@@ -1,7 +1,12 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------++-- NOTE: FIX: we don't have a great way of testing this module, since+-- we can't easily look inside a tarball once its created.+ -- | -- Module      :  Distribution.Simple.SrcDist -- Copyright   :  Simon Marlow 2004@@ -19,89 +24,88 @@ -- The 'createArchive' action uses the external @tar@ program and assumes that -- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows. -- The 'sdist' action now also does some distribution QA checks.---- NOTE: FIX: we don't have a great way of testing this module, since--- we can't easily look inside a tarball once its created.--module Distribution.Simple.SrcDist (-  -- * The top level action-  sdist,--  -- ** Parts of 'sdist'-  printPackageProblems,-  prepareTree,-  createArchive,+module Distribution.Simple.SrcDist+  ( -- * The top level action+    sdist -  -- ** Snapshots-  prepareSnapshotTree,-  snapshotPackage,-  snapshotVersion,-  dateToSnapshotNumber,+    -- ** Parts of 'sdist'+  , printPackageProblems+  , prepareTree+  , createArchive -  -- * Extracting the source files-  listPackageSources,-  listPackageSourcesWithDie,+    -- ** Snapshots+  , prepareSnapshotTree+  , snapshotPackage+  , snapshotVersion+  , dateToSnapshotNumber -  )  where+    -- * Extracting the source files+  , listPackageSources+  , listPackageSourcesWithDie+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () +import Distribution.ModuleName+import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Check hiding (doesFileExist)-import Distribution.Package-import Distribution.ModuleName-import qualified Distribution.ModuleName as ModuleName-import Distribution.Version+import Distribution.Pretty+import Distribution.Simple.BuildPaths import Distribution.Simple.Configure (findDistPrefOrDefault)+import Distribution.Simple.Errors+import Distribution.Simple.Flag import Distribution.Simple.Glob (matchDirFileGlobWithDie)-import Distribution.Simple.Utils-import Distribution.Simple.Setup import Distribution.Simple.PreProcess-import Distribution.Simple.BuildPaths import Distribution.Simple.Program-import Distribution.Pretty-import Distribution.Verbosity+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.SDist+import Distribution.Simple.Utils import Distribution.Utils.Path+import Distribution.Verbosity+import Distribution.Version  import qualified Data.Map as Map import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay)-import System.Directory ( doesFileExist )-import System.IO (IOMode(WriteMode), hPutStrLn, withFile)-import System.FilePath ((</>), (<.>), dropExtension, isRelative)+import System.Directory (doesFileExist)+import System.IO (IOMode (WriteMode), hPutStrLn, withFile) --- |Create a source distribution.-sdist :: PackageDescription     -- ^ information from the tarball-      -> SDistFlags             -- ^ verbosity & snapshot-      -> (FilePath -> FilePath) -- ^ build prefix (temp dir)-      -> [PPSuffixHandler]      -- ^ extra preprocessors (includes suffixes)-      -> IO ()+-- | Create a source distribution.+sdist+  :: PackageDescription+  -- ^ information from the tarball+  -> SDistFlags+  -- ^ verbosity & snapshot+  -> (FilePath -> FilePath)+  -- ^ build prefix (temp dir)+  -> [PPSuffixHandler]+  -- ^ extra preprocessors (includes suffixes)+  -> IO () sdist pkg flags mkTmpDir pps = do--  distPref <- findDistPrefOrDefault $ sDistDistPref flags-  let targetPref   = distPref-      tmpTargetDir = mkTmpDir distPref+  distPref <- findDistPrefOrDefault $ setupDistPref common+  let targetPref = i distPref+      tmpTargetDir = mkTmpDir (i distPref)    -- When given --list-sources, just output the list of sources to a file.   case sDistListSources flags of     Flag path -> withFile path WriteMode $ \outHandle -> do-      ordinary <- listPackageSources verbosity "." pkg pps-      traverse_ (hPutStrLn outHandle) ordinary+      ordinary <- listPackageSources verbosity mbWorkDir pkg pps+      traverse_ (hPutStrLn outHandle . getSymbolicPath) ordinary       notice verbosity $ "List of package sources written to file '" ++ path ++ "'"--    NoFlag    -> do+    NoFlag -> do       -- do some QA       printPackageProblems verbosity pkg        date <- getCurrentTime-      let pkg' | snapshot  = snapshotPackage date pkg-               | otherwise = pkg+      let pkg'+            | snapshot = snapshotPackage date pkg+            | otherwise = pkg        case flagToMaybe (sDistDirectory flags) of         Just targetDir -> do           generateSourceDir targetDir pkg'           info verbosity $ "Source directory created: " ++ targetDir-         Nothing -> do           createDirectoryIfMissingVerbose verbosity True tmpTargetDir           withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do@@ -109,32 +113,37 @@             generateSourceDir targetDir pkg'             targzFile <- createArchive verbosity pkg' tmpDir targetPref             notice verbosity $ "Source tarball created: " ++ targzFile-   where     generateSourceDir :: FilePath -> PackageDescription -> IO ()     generateSourceDir targetDir pkg' = do       setupMessage verbosity "Building source dist for" (packageId pkg')-      prepareTree verbosity pkg' targetDir pps+      prepareTree verbosity mbWorkDir pkg' targetDir pps       when snapshot $         overwriteSnapshotPackageDesc verbosity pkg' targetDir -    verbosity = fromFlag (sDistVerbosity flags)-    snapshot  = fromFlag (sDistSnapshot flags)+    common = sDistCommonFlags flags+    verbosity = fromFlag $ setupVerbosity common+    mbWorkDir = flagToMaybe $ setupWorkingDir common+    i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path+    snapshot = fromFlag (sDistSnapshot flags)  -- | List all source files of a package. -- -- Since @Cabal-3.4@ returns a single list. There shouldn't be any -- executable files, they are hardly portable.---  listPackageSources-    :: Verbosity          -- ^ verbosity-    -> FilePath           -- ^ directory with cabal file-    -> PackageDescription -- ^ info from the cabal file-    -> [PPSuffixHandler]  -- ^ extra preprocessors (include suffixes)-    -> IO [FilePath]      -- ^ relative paths+  :: Verbosity+  -- ^ verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ directory with cabal file+  -> PackageDescription+  -- ^ info from the cabal file+  -> [PPSuffixHandler]+  -- ^ extra preprocessors (include suffixes)+  -> IO [SymbolicPath Pkg File] listPackageSources verbosity cwd pkg_descr0 pps = do-    -- Call helpers that actually do all work.-    listPackageSources' verbosity die' cwd pkg_descr pps+  -- Call helpers that actually do all work.+  listPackageSources' verbosity dieWithException cwd pkg_descr pps   where     pkg_descr = filterAutogenModules pkg_descr0 @@ -144,377 +153,476 @@ -- -- Since @3.4.0.0 listPackageSourcesWithDie-    :: Verbosity          -- ^ verbosity-    -> (Verbosity -> String -> IO [FilePath]) -- ^ 'die'' alternative-    -> FilePath           -- ^ directory with cabal file-    -> PackageDescription -- ^ info from the cabal file-    -> [PPSuffixHandler]  -- ^ extra preprocessors (include suffixes)-    -> IO [FilePath]      -- ^ relative paths+  :: Verbosity+  -- ^ verbosity+  -> (forall res. Verbosity -> CabalException -> IO [res])+  -- ^ 'die'' alternative.+  -- Since 'die'' prefixes the error message with 'errorPrefix',+  -- whatever is passed in here and wants to die should do the same.+  -- See issue #7331.+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ directory with cabal file+  -> PackageDescription+  -- ^ info from the cabal file+  -> [PPSuffixHandler]+  -- ^ extra preprocessors (include suffixes)+  -> IO [SymbolicPath Pkg File] listPackageSourcesWithDie verbosity rip cwd pkg_descr0 pps = do-    -- Call helpers that actually do all work.-    listPackageSources' verbosity rip cwd pkg_descr pps+  -- Call helpers that actually do all work.+  listPackageSources' verbosity rip cwd pkg_descr pps   where     pkg_descr = filterAutogenModules pkg_descr0 - listPackageSources'   :: Verbosity-  -> (Verbosity -> String -> IO [FilePath])-  -> FilePath+  -- ^ verbosity+  -> (forall res. Verbosity -> CabalException -> IO [res])+  -- ^ 'die'' alternative.+  -- Since 'die'' prefixes the error message with 'errorPrefix',+  -- whatever is passed in here and wants to die should do the same.+  -- See issue #7331.+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ directory with cabal file   -> PackageDescription+  -- ^ info from the cabal file   -> [PPSuffixHandler]-  -> IO [FilePath]-listPackageSources' verbosity rip cwd pkg_descr pps =+  -- ^ extra preprocessors (include suffixes)+  -> IO [SymbolicPath Pkg File]+listPackageSources' verbosity rip mbWorkDir pkg_descr pps =   fmap concat . sequenceA $-  [-    -- Library sources.-    fmap concat-    . withAllLib $ \Library {-                      exposedModules = modules,-                      signatures     = sigs,-                      libBuildInfo   = libBi-                    } ->-     allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs)--    -- Executables sources.-  , fmap concat-    . withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do-       biSrcs  <- allSourcesBuildInfo verbosity rip cwd exeBi pps []-       mainSrc <- findMainExeFile verbosity cwd exeBi pps mainPath-       return (mainSrc:biSrcs)--    -- Foreign library sources-  , fmap concat-    . withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do-       biSrcs   <- allSourcesBuildInfo verbosity rip cwd flibBi pps []-       defFiles <- traverse (findModDefFile verbosity cwd flibBi pps)-         (foreignLibModDefFile flib)-       return (defFiles ++ biSrcs)--    -- Test suites sources.-  , fmap concat-    . withAllTest $ \t -> do-       let bi  = testBuildInfo t-       case testInterface t of-         TestSuiteExeV10 _ mainPath -> do-           biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps []-           srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath-           return (srcMainFile:biSrcs)-         TestSuiteLibV09 _ m ->-           allSourcesBuildInfo verbosity rip cwd bi pps [m]-         TestSuiteUnsupported tp ->-           rip verbosity $ "Unsupported test suite type: " ++ show tp--    -- Benchmarks sources.-  , fmap concat-    . withAllBenchmark $ \bm -> do-       let  bi = benchmarkBuildInfo bm-       case benchmarkInterface bm of-         BenchmarkExeV10 _ mainPath -> do-           biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps []-           srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath-           return (srcMainFile:biSrcs)-         BenchmarkUnsupported tp ->-            rip verbosity $ "Unsupported benchmark type: " ++ show tp--    -- Data files.-  , fmap concat-    . for (dataFiles pkg_descr) $ \filename -> do-        let srcDataDirRaw                   = dataDir pkg_descr-            srcDataDir | null srcDataDirRaw = "."-                       | otherwise          = srcDataDirRaw-        matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir </> filename)--    -- Extra source files.-  , fmap concat . for (extraSrcFiles pkg_descr) $ \fpath ->-    matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath--    -- Extra doc files.-  , fmap concat-    . for (extraDocFiles pkg_descr) $ \ filename ->-        matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd filename--    -- License file(s).-  , return (map getSymbolicPath $ licenseFiles pkg_descr)--    -- Install-include files, without autogen-include files-  , fmap concat-    . withAllLib $ \ l -> do-       let lbi   = libBuildInfo l-           incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi)-           relincdirs = "." : filter isRelative (includeDirs lbi)-       traverse (fmap snd . findIncludeFile verbosity cwd relincdirs) incls--    -- Setup script, if it exists.-  , fmap (maybe [] (\f -> [f])) $ findSetupFile cwd--    -- The .cabal file itself.-  , fmap (\d -> [d]) (tryFindPackageDescCwd verbosity cwd ".")--  ]+    [ -- Library sources.+      fmap concat+        . withAllLib+        $ \Library+            { exposedModules = modules+            , signatures = sigs+            , libBuildInfo = libBi+            } ->+            allSourcesBuildInfo verbosity rip mbWorkDir libBi pps (modules ++ sigs)+    , -- Executables sources.+      fmap concat+        . withAllExe+        $ \Executable{modulePath = mainPath, buildInfo = exeBi} -> do+          biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir exeBi pps []+          mainSrc <- findMainExeFile verbosity mbWorkDir exeBi pps mainPath+          return (mainSrc : biSrcs)+    , -- Foreign library sources+      fmap concat+        . withAllFLib+        $ \flib@(ForeignLib{foreignLibBuildInfo = flibBi}) -> do+          biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir flibBi pps []+          defFiles <-+            traverse+              (findModDefFile verbosity mbWorkDir flibBi pps)+              (foreignLibModDefFile flib)+          return (defFiles ++ biSrcs)+    , -- Test suites sources.+      fmap concat+        . withAllTest+        $ \t -> do+          let bi = testBuildInfo t+          case testInterface t of+            TestSuiteExeV10 _ mainPath -> do+              biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir bi pps []+              srcMainFile <- findMainExeFile verbosity mbWorkDir bi pps mainPath+              return (srcMainFile : biSrcs)+            TestSuiteLibV09 _ m ->+              allSourcesBuildInfo verbosity rip mbWorkDir bi pps [m]+            TestSuiteUnsupported tp ->+              rip verbosity $ UnsupportedTestSuite (show tp)+    , -- Benchmarks sources.+      fmap concat+        . withAllBenchmark+        $ \bm -> do+          let bi = benchmarkBuildInfo bm+          case benchmarkInterface bm of+            BenchmarkExeV10 _ mainPath -> do+              biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir bi pps []+              srcMainFile <- findMainExeFile verbosity mbWorkDir bi pps mainPath+              return (srcMainFile : biSrcs)+            BenchmarkUnsupported tp ->+              rip verbosity $ UnsupportedBenchMark (show tp)+    , -- Data files.+      fmap concat+        . for (dataFiles pkg_descr)+        $ \filename ->+          do+            let srcDataDirRaw = dataDir pkg_descr+                srcDataFile :: SymbolicPath Pkg File+                srcDataFile+                  | null (getSymbolicPath srcDataDirRaw) = sameDirectory </> filename+                  | otherwise = srcDataDirRaw </> filename+            fmap coerceSymbolicPath+              <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir srcDataFile+    , -- Extra source files.+      fmap concat . for (extraSrcFiles pkg_descr) $ \fpath ->+        fmap relativeSymbolicPath+          <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir fpath+    , -- Extra doc files.+      fmap concat+        . for (extraDocFiles pkg_descr)+        $ \filename ->+          fmap (coerceSymbolicPath . relativeSymbolicPath)+            <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir filename+    , -- Extra files.+      fmap concat . for (extraFiles pkg_descr) $ \fpath ->+        fmap relativeSymbolicPath+          <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir fpath+    , -- License file(s).+      return (map (relativeSymbolicPath . coerceSymbolicPath) $ licenseFiles pkg_descr)+    , -- Install-include files, without autogen-include files+      fmap concat+        . withAllLib+        $ \l -> do+          let lbi = libBuildInfo l+              incls = fmap getSymbolicPath $ filter (`notElem` autogenIncludes lbi) (installIncludes lbi)+              relincdirs = fmap getSymbolicPath $ sameDirectory : mapMaybe symbolicPathRelative_maybe (includeDirs lbi)+          traverse (fmap (makeSymbolicPath . snd) . findIncludeFile verbosity cwd relincdirs) incls+    , -- Setup script, if it exists.+      fmap (maybe [] (\f -> [makeSymbolicPath f])) $ findSetupFile cwd+    , -- SetupHooks script, if it exists.+      fmap (maybe [] (\f -> [makeSymbolicPath f])) $ findSetupHooksFile cwd+    , -- The .cabal file itself.+      fmap (\d -> [d]) (coerceSymbolicPath . relativeSymbolicPath <$> tryFindPackageDesc verbosity mbWorkDir)+    ]   where+    cwd = maybe "." getSymbolicPath mbWorkDir     -- We have to deal with all libs and executables, so we have local     -- versions of these functions that ignore the 'buildable' attribute:-    withAllLib       action = traverse action (allLibraries pkg_descr)-    withAllFLib      action = traverse action (foreignLibs pkg_descr)-    withAllExe       action = traverse action (executables pkg_descr)-    withAllTest      action = traverse action (testSuites pkg_descr)+    withAllLib action = traverse action (allLibraries pkg_descr)+    withAllFLib action = traverse action (foreignLibs pkg_descr)+    withAllExe action = traverse action (executables pkg_descr)+    withAllTest action = traverse action (testSuites pkg_descr)     withAllBenchmark action = traverse action (benchmarks pkg_descr) ---- |Prepare a directory tree of source files.-prepareTree :: Verbosity          -- ^verbosity-            -> PackageDescription -- ^info from the cabal file-            -> FilePath           -- ^source tree to populate-            -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)-            -> IO ()-prepareTree verbosity pkg_descr0 targetDir pps = do-    ordinary <- listPackageSources verbosity "." pkg_descr pps-    installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary)-    maybeCreateDefaultSetupScript targetDir+-- | Prepare a directory tree of source files.+prepareTree+  :: Verbosity+  -- ^ verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ working directory+  -> PackageDescription+  -- ^ info from the cabal file+  -> FilePath+  -- ^ source tree to populate+  -> [PPSuffixHandler]+  -- ^ extra preprocessors (includes suffixes)+  -> IO ()+prepareTree verbosity mbWorkDir pkg_descr0 targetDir pps = do+  ordinary <- listPackageSources verbosity mbWorkDir pkg_descr pps+  installOrdinaryFiles verbosity targetDir (zip (repeat []) $ map i ordinary)+  maybeCreateDefaultSetupScript targetDir   where+    i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path     pkg_descr = filterAutogenModules pkg_descr0  -- | Find the setup script file, if it exists. findSetupFile :: FilePath -> IO (Maybe FilePath) findSetupFile targetDir = do-  hsExists  <- doesFileExist (targetDir </> setupHs)+  hsExists <- doesFileExist (targetDir </> setupHs)   lhsExists <- doesFileExist (targetDir </> setupLhs)   if hsExists     then return (Just setupHs)-    else if lhsExists-         then return (Just setupLhs)-         else return Nothing-    where-      setupHs  = "Setup.hs"-      setupLhs = "Setup.lhs"+    else+      if lhsExists+        then return (Just setupLhs)+        else return Nothing+  where+    setupHs = "Setup.hs"+    setupLhs = "Setup.lhs" +-- | Find the setup hooks script file, if it exists.+findSetupHooksFile :: FilePath -> IO (Maybe FilePath)+findSetupHooksFile targetDir = do+  hsExists <- doesFileExist (targetDir </> setupHs)+  lhsExists <- doesFileExist (targetDir </> setupLhs)+  if hsExists+    then return (Just setupHs)+    else+      if lhsExists+        then return (Just setupLhs)+        else return Nothing+  where+    setupHs = "SetupHooks.hs"+    setupLhs = "SetupHooks.lhs"+ -- | Create a default setup script in the target directory, if it doesn't exist. maybeCreateDefaultSetupScript :: FilePath -> IO () maybeCreateDefaultSetupScript targetDir = do   mSetupFile <- findSetupFile targetDir   case mSetupFile of     Just _setupFile -> return ()-    Nothing         -> do-      writeUTF8File (targetDir </> "Setup.hs") $ unlines [-        "import Distribution.Simple",-        "main = defaultMain"]+    Nothing -> do+      writeUTF8File (targetDir </> "Setup.hs") $+        unlines+          [ "import Distribution.Simple"+          , "main = defaultMain"+          ]  -- | Find the main executable file. findMainExeFile   :: Verbosity-  -> FilePath -- ^ cwd+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ working directory   -> BuildInfo   -> [PPSuffixHandler]-  -> FilePath -- ^ main-is-  -> IO FilePath+  -> RelativePath Source File+  -- ^ main-is+  -> IO (SymbolicPath Pkg File) findMainExeFile verbosity cwd exeBi pps mainPath = do-  ppFile <- findFileCwdWithExtension cwd (ppSuffixes pps) (map getSymbolicPath (hsSourceDirs exeBi))-            (dropExtension mainPath)+  ppFile <-+    findFileCwdWithExtension+      cwd+      (ppSuffixes pps)+      (hsSourceDirs exeBi)+      (dropExtensionsSymbolicPath mainPath)   case ppFile of-    Nothing -> findFileCwd verbosity cwd (map getSymbolicPath (hsSourceDirs exeBi)) mainPath+    Nothing -> findFileCwd verbosity cwd (hsSourceDirs exeBi) mainPath     Just pp -> return pp  -- | Find a module definition file -- -- TODO: I don't know if this is right findModDefFile-  :: Verbosity -> FilePath -> BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> BuildInfo+  -> [PPSuffixHandler]+  -> RelativePath Source File+  -> IO (SymbolicPath Pkg File) findModDefFile verbosity cwd flibBi _pps modDefPath =-    findFileCwd verbosity cwd ("." : map getSymbolicPath (hsSourceDirs flibBi)) modDefPath+  findFileCwd verbosity cwd (sameDirectory : hsSourceDirs flibBi) modDefPath  -- | Given a list of include paths, try to find the include file named -- @f@. Return the name of the file and the full path, or exit with error if -- there's no such file. findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath)-findIncludeFile verbosity _ [] f = die' verbosity ("can't find include file " ++ f)-findIncludeFile verbosity cwd (d:ds) f = do-  let path = (d </> f)+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+  if b then return (f, path) else findIncludeFile verbosity cwd ds f --- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' +-- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' -- and 'other-modules'. filterAutogenModules :: PackageDescription -> PackageDescription-filterAutogenModules pkg_descr0 = mapLib filterAutogenModuleLib $-                                 mapAllBuildInfo filterAutogenModuleBI pkg_descr0+filterAutogenModules pkg_descr0 =+  mapLib filterAutogenModuleLib $+    mapAllBuildInfo filterAutogenModuleBI pkg_descr0   where-    mapLib f pkg = pkg { library      = fmap f (library pkg)-                       , subLibraries = map f (subLibraries pkg) }-    filterAutogenModuleLib lib = lib {-      exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib)-    }-    filterAutogenModuleBI bi = bi {-      otherModules   = filter (filterFunction bi) (otherModules bi)-    }+    mapLib f pkg =+      pkg+        { library = fmap f (library pkg)+        , subLibraries = map f (subLibraries pkg)+        }+    filterAutogenModuleLib lib =+      lib+        { exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib)+        }+    filterAutogenModuleBI bi =+      bi+        { otherModules = filter (filterFunction bi) (otherModules bi)+        }     pathsModule = autogenPathsModuleName pkg_descr0+    packageInfoModule = autogenPackageInfoModuleName pkg_descr0     filterFunction bi = \mn ->-                                   mn /= pathsModule-                                && not (mn `elem` autogenModules bi)+      mn /= pathsModule+        && mn /= packageInfoModule+        && not (mn `elem` autogenModules bi)  -- | Prepare a directory tree of source files for a snapshot version. -- It is expected that the appropriate snapshot version has already been set -- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'.--- prepareSnapshotTree-  :: Verbosity          -- ^verbosity-  -> PackageDescription -- ^info from the cabal file-  -> FilePath           -- ^source tree to populate-  -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)+  :: Verbosity+  -- ^ verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ working directory+  -> PackageDescription+  -- ^ info from the cabal file+  -> FilePath+  -- ^ source tree to populate+  -> [PPSuffixHandler]+  -- ^ extra preprocessors (includes suffixes)   -> IO ()-prepareSnapshotTree verbosity pkg targetDir pps = do-  prepareTree verbosity pkg targetDir pps+prepareSnapshotTree verbosity mbWorkDir pkg targetDir pps = do+  prepareTree verbosity mbWorkDir pkg targetDir pps   overwriteSnapshotPackageDesc verbosity pkg targetDir -overwriteSnapshotPackageDesc :: Verbosity          -- ^verbosity-                             -> PackageDescription -- ^info from the cabal file-                             -> FilePath           -- ^source tree-                             -> IO ()+overwriteSnapshotPackageDesc+  :: Verbosity+  -- ^ verbosity+  -> PackageDescription+  -- ^ info from the cabal file+  -> FilePath+  -- ^ source tree+  -> IO () overwriteSnapshotPackageDesc verbosity pkg targetDir = do-    -- We could just writePackageDescription targetDescFile pkg_descr,-    -- but that would lose comments and formatting.-    descFile <- defaultPackageDesc verbosity-    withUTF8FileContents descFile $-      writeUTF8File (targetDir </> descFile)-        . unlines . map (replaceVersion (packageVersion pkg)) . lines-+  -- We could just writePackageDescription targetDescFile pkg_descr,+  -- but that would lose comments and formatting.+  descFile <- getSymbolicPath <$> defaultPackageDescCwd verbosity+  withUTF8FileContents descFile $+    writeUTF8File (targetDir </> descFile)+      . unlines+      . map (replaceVersion (packageVersion pkg))+      . lines   where     replaceVersion :: Version -> String -> String     replaceVersion version line-      | "version:" `isPrefixOf` map toLower line-                  = "version: " ++ prettyShow version+      | "version:" `isPrefixOf` map toLower line =+          "version: " ++ prettyShow version       | otherwise = line  -- | Modifies a 'PackageDescription' by appending a snapshot number -- corresponding to the given date.--- snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription snapshotPackage date pkg =-  pkg {-    package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) }-  }-  where pkgid = packageId pkg+  pkg+    { package = pkgid{pkgVersion = snapshotVersion date (pkgVersion pkgid)}+    }+  where+    pkgid = packageId pkg  -- | Modifies a 'Version' by appending a snapshot number corresponding -- to the given date.--- snapshotVersion :: UTCTime -> Version -> Version snapshotVersion date = alterVersion (++ [dateToSnapshotNumber date])  -- | Given a date produce a corresponding integer representation. -- For example given a date @18/03/2008@ produce the number @20080318@.--- dateToSnapshotNumber :: UTCTime -> Int dateToSnapshotNumber date = case toGregorian (utctDay date) of-                            (year, month, day) ->-                                fromIntegral year * 10000-                              + month             * 100-                              + day+  (year, month, day) ->+    fromIntegral year * 10000+      + month * 100+      + day  -- | Create an archive from a tree of source files, and clean up the tree. createArchive-    :: Verbosity            -- ^ verbosity-    -> PackageDescription   -- ^ info from cabal file-    -> FilePath             -- ^ source tree to archive-    -> FilePath             -- ^ name of archive to create-    -> IO FilePath+  :: Verbosity+  -- ^ verbosity+  -> PackageDescription+  -- ^ info from cabal file+  -> FilePath+  -- ^ source tree to archive+  -> FilePath+  -- ^ name of archive to create+  -> IO FilePath createArchive verbosity pkg_descr tmpDir targetPref = do   let tarBallFilePath = targetPref </> tarBallName pkg_descr <.> "tar.gz"   (tarProg, _) <- requireProgram verbosity tarProgram defaultProgramDb-  let formatOptSupported = maybe False (== "YES") $-                           Map.lookup "Supports --format"-                           (programProperties tarProg)+  let formatOptSupported =+        maybe False (== "YES") $+          Map.lookup+            "Supports --format"+            (programProperties tarProg)   runProgram verbosity tarProg $     -- Hmm: I could well be skating on thinner ice here by using the -C option     -- (=> seems to be supported at least by GNU and *BSD tar) [The     -- prev. solution used pipes and sub-command sequences to set up the paths     -- correctly, which is problematic in a Windows setting.]     ["-czf", tarBallFilePath, "-C", tmpDir]-    ++ (if formatOptSupported then ["--format", "ustar"] else [])-    ++ [tarBallName pkg_descr]+      ++ (if formatOptSupported then ["--format", "ustar"] else [])+      ++ [tarBallName pkg_descr]   return tarBallFilePath  -- | Given a buildinfo, return the names of all source files. allSourcesBuildInfo-    :: Verbosity-    -> (Verbosity -> String -> IO [FilePath])-    -> FilePath          -- ^ cwd -- change me to 'BuildPath Absolute PackageDir'-    -> BuildInfo-    -> [PPSuffixHandler] -- ^ Extra preprocessors-    -> [ModuleName]      -- ^ Exposed modules-    -> IO [FilePath]-allSourcesBuildInfo verbosity rip cwd bi pps modules = do-  let searchDirs = map getSymbolicPath (hsSourceDirs bi)-  sources <- fmap concat $ sequenceA $-    [ let file = ModuleName.toFilePath module_-      -- NB: *Not* findFileWithExtension, because the same source-      -- file may show up in multiple paths due to a conditional;-      -- we need to package all of them.  See #367.-      in findAllFilesCwdWithExtension cwd suffixes searchDirs file-         >>= nonEmpty' (notFound module_) return-    | module_ <- modules ++ otherModules bi ]-  bootFiles <- sequenceA-    [ let file = ModuleName.toFilePath module_-          fileExts = ["hs-boot", "lhs-boot"]-      in findFileCwdWithExtension cwd fileExts (map getSymbolicPath (hsSourceDirs bi)) file-    | module_ <- modules ++ otherModules bi ]--  return $ sources ++ catMaybes bootFiles ++ cSources bi ++ cxxSources bi ++-           cmmSources bi ++ asmSources bi ++ jsSources bi+  :: Verbosity+  -> (Verbosity -> CabalException -> IO [SymbolicPath Pkg File])+  -- ^ 'die'' alternative.+  -- Since 'die'' prefixes the error message with 'errorPrefix',+  -- whatever is passed in here and wants to die should do the same.+  -- See issue #7331.+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ working directory+  -> BuildInfo+  -> [PPSuffixHandler]+  -- ^ Extra preprocessors+  -> [ModuleName]+  -- ^ Exposed modules+  -> IO [SymbolicPath Pkg File]+allSourcesBuildInfo verbosity rip mbWorkDir bi pps modules = do+  let searchDirs = hsSourceDirs bi+  sources <-+    fmap concat $+      sequenceA $+        [ let file = moduleNameSymbolicPath module_+           in -- NB: *Not* findFileWithExtension, because the same source+              -- file may show up in multiple paths due to a conditional;+              -- we need to package all of them.  See #367.+              findAllFilesCwdWithExtension mbWorkDir suffixes searchDirs file+                >>= nonEmpty' (notFound module_) return+        | module_ <- modules ++ otherModules bi+        ]+  bootFiles <-+    sequenceA+      [ let file = moduleNameSymbolicPath module_+            fileExts = builtinHaskellBootSuffixes+         in findFileCwdWithExtension mbWorkDir fileExts (hsSourceDirs bi) file+      | module_ <- modules ++ otherModules bi+      ] +  return $+    sources+      ++ catMaybes bootFiles+      ++ cSources bi+      ++ cxxSources bi+      ++ cmmSources bi+      ++ asmSources bi+      ++ jsSources bi   where     nonEmpty' :: b -> ([a] -> b) -> [a] -> b     nonEmpty' x _ [] = x     nonEmpty' _ f xs = f xs -    suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"]--    notFound :: ModuleName -> IO [FilePath]-    notFound m = rip verbosity $ "Error: Could not find module: " ++ prettyShow m-                 ++ " with any suffix: " ++ show suffixes ++ ". If the module "-                 ++ "is autogenerated it should be added to 'autogen-modules'."+    suffixes = ppSuffixes pps ++ builtinHaskellSuffixes +    notFound :: ModuleName -> IO [SymbolicPath Pkg File]+    notFound m =+      rip verbosity $ NoModuleFound m suffixes  -- | Note: must be called with the CWD set to the directory containing -- the '.cabal' file. printPackageProblems :: Verbosity -> PackageDescription -> IO () printPackageProblems verbosity pkg_descr = do-  ioChecks      <- checkPackageFiles verbosity pkg_descr "."+  ioChecks <- checkPackageFiles verbosity pkg_descr "."   let pureChecks = checkConfiguredPackage pkg_descr-      isDistError (PackageDistSuspicious     _) = False-      isDistError (PackageDistSuspiciousWarn _) = False-      isDistError _                             = True-      (errors, warnings) = partition isDistError (pureChecks ++ ioChecks)+      (errors, warnings) = partition isHackageDistError (pureChecks ++ ioChecks)   unless (null errors) $-      notice verbosity $ "Distribution quality errors:\n"-                      ++ unlines (map explanation errors)+    notice verbosity $+      "Distribution quality errors:\n"+        ++ unlines (map ppPackageCheck errors)   unless (null warnings) $-      notice verbosity $ "Distribution quality warnings:\n"-                      ++ unlines (map explanation warnings)+    notice verbosity $+      "Distribution quality warnings:\n"+        ++ unlines (map ppPackageCheck warnings)   unless (null errors) $-      notice verbosity-        "Note: the public hackage server would reject this package."+    notice+      verbosity+      "Note: the public hackage server would reject this package."  ------------------------------------------------------------  -- | The name of the tarball without extension--- tarBallName :: PackageDescription -> String tarBallName = prettyShow . packageId -mapAllBuildInfo :: (BuildInfo -> BuildInfo)-                -> (PackageDescription -> PackageDescription)-mapAllBuildInfo f pkg = pkg {-    library     = fmap mapLibBi (library pkg),-    subLibraries = fmap mapLibBi (subLibraries pkg),-    foreignLibs = fmap mapFLibBi (foreignLibs pkg),-    executables = fmap mapExeBi (executables pkg),-    testSuites  = fmap mapTestBi (testSuites pkg),-    benchmarks  = fmap mapBenchBi (benchmarks pkg)-  }+mapAllBuildInfo+  :: (BuildInfo -> BuildInfo)+  -> (PackageDescription -> PackageDescription)+mapAllBuildInfo f pkg =+  pkg+    { library = fmap mapLibBi (library pkg)+    , subLibraries = fmap mapLibBi (subLibraries pkg)+    , foreignLibs = fmap mapFLibBi (foreignLibs pkg)+    , executables = fmap mapExeBi (executables pkg)+    , testSuites = fmap mapTestBi (testSuites pkg)+    , benchmarks = fmap mapBenchBi (benchmarks pkg)+    }   where-    mapLibBi   lib  = lib  { libBuildInfo        = f (libBuildInfo lib) }-    mapFLibBi  flib = flib { foreignLibBuildInfo = f (foreignLibBuildInfo flib) }-    mapExeBi   exe  = exe  { buildInfo           = f (buildInfo exe) }-    mapTestBi  tst  = tst  { testBuildInfo       = f (testBuildInfo tst) }-    mapBenchBi bm   = bm   { benchmarkBuildInfo  = f (benchmarkBuildInfo bm) }+    mapLibBi lib = lib{libBuildInfo = f (libBuildInfo lib)}+    mapFLibBi flib = flib{foreignLibBuildInfo = f (foreignLibBuildInfo flib)}+    mapExeBi exe = exe{buildInfo = f (buildInfo exe)}+    mapTestBi tst = tst{testBuildInfo = f (testBuildInfo tst)}+    mapBenchBi bm = bm{benchmarkBuildInfo = f (benchmarkBuildInfo bm)}
src/Distribution/Simple/Test.hs view
@@ -1,7 +1,12 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.Test -- Copyright   :  Thomas Tuegel 2010@@ -13,124 +18,191 @@ -- This is the entry point into testing a built package. It performs the -- \"@.\/setup test@\" action. It runs test suites designated in the package -- description and reports on the results.- module Distribution.Simple.Test-    ( test-    ) where+  ( test+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD+import Distribution.Pretty+import Distribution.Simple.Build (addInternalBuildTools) import Distribution.Simple.Compiler import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI-import qualified Distribution.Types.LocalBuildInfo as LBI-import Distribution.Simple.Setup-import Distribution.Simple.UserHooks+import Distribution.Simple.Setup.Test import qualified Distribution.Simple.Test.ExeV10 as ExeV10 import qualified Distribution.Simple.Test.LibV09 as LibV09 import Distribution.Simple.Test.Log+import Distribution.Simple.UserHooks import Distribution.Simple.Utils import Distribution.TestSuite-import Distribution.Pretty+import qualified Distribution.Types.LocalBuildInfo as LBI+import Distribution.Types.UnqualComponentName+import Distribution.Utils.Path +import Distribution.Simple.Configure (getInstalledPackagesById)+import Distribution.Simple.Errors+import Distribution.Simple.Register (internalPackageDBPath)+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Config+import Distribution.Types.ExposedModule+import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (libraryDirs), exposedModules)+import Distribution.Types.LocalBuildInfo (LocalBuildInfo (..)) import System.Directory-    ( createDirectoryIfMissing, doesFileExist, getDirectoryContents-    , removeFile )-import System.FilePath ( (</>) )---- |Perform the \"@.\/setup test@\" action.-test :: Args                    -- ^positional command-line arguments-     -> PD.PackageDescription   -- ^information from the .cabal file-     -> LBI.LocalBuildInfo      -- ^information from the configure step-     -> TestFlags               -- ^flags sent to test-     -> IO ()-test args pkg_descr lbi flags = do-    let verbosity = fromFlag $ testVerbosity flags-        machineTemplate = fromFlag $ testMachineLog flags-        distPref = fromFlag $ testDistPref flags-        testLogDir = distPref </> "test"-        testNames = args-        pkgTests = PD.testSuites pkg_descr-        enabledTests = LBI.enabledTestLBIs pkg_descr lbi--        doTest :: ((PD.TestSuite, LBI.ComponentLocalBuildInfo),-                    Maybe TestSuiteLog) -> IO TestSuiteLog-        doTest ((suite, clbi), _) =-            case PD.testInterface suite of-              PD.TestSuiteExeV10 _ _ ->-                  ExeV10.runTest pkg_descr lbi clbi flags suite+  ( createDirectoryIfMissing+  , doesFileExist+  , getDirectoryContents+  , removeFile+  ) -              PD.TestSuiteLibV09 _ _ ->-                  LibV09.runTest pkg_descr lbi clbi flags suite+-- | Perform the \"@.\/setup test@\" action.+test+  :: Args+  -- ^ positional command-line arguments+  -> PD.PackageDescription+  -- ^ information from the .cabal file+  -> LBI.LocalBuildInfo+  -- ^ information from the configure step+  -> TestFlags+  -- ^ flags sent to test+  -> IO ()+test args pkg_descr lbi0 flags = do+  curDir <- LBI.absoluteWorkingDirLBI lbi0+  let common = testCommonFlags flags+      verbosity = fromFlag $ setupVerbosity common+      distPref = fromFlag $ setupDistPref common+      i = LBI.interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path+      machineTemplate = fromFlag $ testMachineLog flags+      testLogDir = distPref </> makeRelativePathEx "test"+      testNames = args+      pkgTests = PD.testSuites pkg_descr+      enabledTests = LBI.enabledTestLBIs pkg_descr lbi+      -- We must add the internalPkgDB to the package database stack to lookup+      -- the path to HPC dirs of libraries local to this package+      internalPkgDb = internalPackageDBPath lbi0 distPref+      lbi = lbi0{withPackageDB = withPackageDB lbi0 ++ [SpecificPackageDB internalPkgDb]} -              _ -> return TestSuiteLog-                  { testSuiteName = PD.testName suite-                  , testLogs = TestLog+      doTest+        :: HPCMarkupInfo+        -> ( (PD.TestSuite, LBI.ComponentLocalBuildInfo)+           , Maybe TestSuiteLog+           )+        -> IO TestSuiteLog+      doTest hpcMarkupInfo ((suite, clbi), _) = do+        let lbiForTest =+              lbi+                { withPrograms =+                    -- Include any build-tool-depends on build tools internal to the current package.+                    addInternalBuildTools+                      curDir+                      pkg_descr+                      lbi+                      (PD.testBuildInfo suite)+                      (withPrograms lbi)+                }+        case PD.testInterface suite of+          PD.TestSuiteExeV10 _ _ ->+            ExeV10.runTest pkg_descr lbiForTest clbi hpcMarkupInfo flags suite+          PD.TestSuiteLibV09 _ _ ->+            LibV09.runTest pkg_descr lbiForTest clbi hpcMarkupInfo flags suite+          _ ->+            return+              TestSuiteLog+                { testSuiteName = PD.testName suite+                , testLogs =+                    TestLog                       { testName = unUnqualComponentName $ PD.testName suite                       , testOptionsReturned = []                       , testResult =-                          Error $ "No support for running test suite type: "-                                  ++ show (pretty $ PD.testType suite)+                          Error $+                            "No support for running test suite type: "+                              ++ show (pretty $ PD.testType suite)                       }-                  , logFile = ""-                  }+                , logFile = ""+                } -    unless (PD.hasTests pkg_descr) $ do-        notice verbosity "Package has no test suites."-        exitSuccess+  unless (PD.hasTests pkg_descr) $ do+    notice verbosity "Package has no test suites."+    exitSuccess -    when (PD.hasTests pkg_descr && null enabledTests) $-        die' verbosity $-              "No test suites enabled. Did you remember to configure with "-           ++ "\'--enable-tests\'?"+  when (PD.hasTests pkg_descr && null enabledTests) $+    dieWithException verbosity NoTestSuitesEnabled -    testsToRun <- case testNames of-            [] -> return $ zip enabledTests $ repeat Nothing-            names -> for names $ \tName ->-                let testMap = zip enabledNames enabledTests-                    enabledNames = map (PD.testName . fst) enabledTests-                    allNames = map PD.testName pkgTests-                    tCompName = mkUnqualComponentName tName-                in case lookup tCompName testMap of-                    Just t -> return (t, Nothing)-                    _ | tCompName `elem` allNames ->-                          die' verbosity $ "Package configured with test suite "-                                ++ tName ++ " disabled."-                      | otherwise -> die' verbosity $ "no such test: " ++ tName+  testsToRun <- case testNames of+    [] -> return $ zip enabledTests $ repeat Nothing+    names -> for names $ \tName ->+      let testMap = zip enabledNames enabledTests+          enabledNames = map (PD.testName . fst) enabledTests+          allNames = map PD.testName pkgTests+          tCompName = mkUnqualComponentName tName+       in case lookup tCompName testMap of+            Just t -> return (t, Nothing)+            _+              | tCompName `elem` allNames ->+                  dieWithException verbosity $ TestNameDisabled tName+              | otherwise -> dieWithException verbosity $ NoSuchTest tName -    createDirectoryIfMissing True testLogDir+  createDirectoryIfMissing True $ i testLogDir -    -- Delete ordinary files from test log directory.-    getDirectoryContents testLogDir-        >>= filterM doesFileExist . map (testLogDir </>)-        >>= traverse_ removeFile+  -- Delete ordinary files from test log directory.+  getDirectoryContents (i testLogDir)+    >>= filterM doesFileExist . map (i testLogDir </>)+    >>= traverse_ removeFile -    let totalSuites = length testsToRun-    notice verbosity $ "Running " ++ show totalSuites ++ " test suites..."-    suites <- traverse doTest testsToRun-    let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites }-        packageLogFile = (</>) testLogDir-            $ packageLogPath machineTemplate pkg_descr lbi-    allOk <- summarizePackage verbosity packageLog-    writeFile packageLogFile $ show packageLog+  -- 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+  -- the hpc artifacts into the extraCompilationArtifacts directory, which, at+  -- install time, is copied into the ghc-pkg database files.+  -- 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 $+          fromFlagOrDefault [] (configCoverageFor (configFlags lbi))+            <> extraCoverageFor lbi+  ipkginfos <- getInstalledPackagesById verbosity lbi MissingCoveredInstalledLibrary coverageFor+  let ( concat -> pathsToLibsArtifacts+        , concat -> libsModulesToInclude+        ) =+          unzip $+            map+              ( \ip ->+                  ( map ((</> coerceSymbolicPath extraCompilationArtifacts) . makeSymbolicPath) $ libraryDirs ip+                  , map exposedName $ exposedModules ip+                  )+              )+              ipkginfos+      hpcMarkupInfo = HPCMarkupInfo{pathsToLibsArtifacts, libsModulesToInclude} -    when (LBI.testCoverage lbi) $-        markupPackage verbosity lbi distPref pkg_descr $-            map (fst . fst) testsToRun+  let totalSuites = length testsToRun+  notice verbosity $ "Running " ++ show totalSuites ++ " test suites..."+  suites <- traverse (doTest hpcMarkupInfo) testsToRun+  let packageLog = (localPackageLog pkg_descr lbi){testSuites = suites}+      packageLogFile =+        i testLogDir+          </> packageLogPath machineTemplate pkg_descr lbi+  allOk <- summarizePackage verbosity packageLog+  writeFile packageLogFile $ show packageLog -    unless allOk exitFailure+  when (LBI.testCoverage lbi) $+    markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr $+      map (fst . fst) testsToRun -packageLogPath :: PathTemplate-               -> PD.PackageDescription-               -> LBI.LocalBuildInfo-               -> FilePath+  unless allOk exitFailure++packageLogPath+  :: PathTemplate+  -> PD.PackageDescription+  -> LBI.LocalBuildInfo+  -> FilePath packageLogPath template pkg_descr lbi =-    fromPathTemplate $ substPathTemplate env template-    where-        env = initialPathTemplateEnv-                (PD.package pkg_descr) (LBI.localUnitId lbi)-                (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi)+  fromPathTemplate $ substPathTemplate env template+  where+    env =+      initialPathTemplateEnv+        (PD.package pkg_descr)+        (LBI.localUnitId lbi)+        (compilerInfo $ LBI.compiler lbi)+        (LBI.hostPlatform lbi)
src/Distribution/Simple/Test/ExeV10.hs view
@@ -2,192 +2,253 @@ {-# LANGUAGE RankNTypes #-}  module Distribution.Simple.Test.ExeV10-       ( runTest-       ) where+  ( runTest+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Types.UnqualComponentName-import Distribution.Compat.CreatePipe-import Distribution.Compat.Environment import qualified Distribution.PackageDescription as PD-import Distribution.Simple.Build.PathsModule import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler+import Distribution.Simple.Errors+import Distribution.Simple.Flag import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI-import qualified Distribution.Types.LocalBuildInfo as LBI-import Distribution.Simple.Setup+  ( ComponentLocalBuildInfo (..)+  , buildDir+  , depLibraryPaths+  )+import Distribution.Simple.Program.Db+import Distribution.Simple.Program.Find+import Distribution.Simple.Program.Run+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Test import Distribution.Simple.Test.Log import Distribution.Simple.Utils import Distribution.System import Distribution.TestSuite-import Distribution.Pretty+import qualified Distribution.Types.LocalBuildInfo as LBI+  ( LocalBuildInfo (..)+  , localUnitId+  , testCoverage+  )+import Distribution.Types.UnqualComponentName import Distribution.Verbosity -import System.Directory-    ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist-    , getCurrentDirectory, removeDirectoryRecursive )-import System.FilePath ( (</>), (<.>) )-import System.IO ( stdout, stderr )+import Distribution.Utils.Path  import qualified Data.ByteString.Lazy as LBS--runTest :: PD.PackageDescription-        -> LBI.LocalBuildInfo-        -> LBI.ComponentLocalBuildInfo-        -> TestFlags-        -> PD.TestSuite-        -> IO TestSuiteLog-runTest pkg_descr lbi clbi flags suite = do-    let isCoverageEnabled = LBI.testCoverage lbi-        way = guessWay lbi-        tixDir_ = tixDir distPref way testName'+import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI, packageRoot)+import System.Directory+  ( createDirectoryIfMissing+  , doesDirectoryExist+  , doesFileExist+  , removeDirectoryRecursive+  )+import System.IO (stderr, stdout)+import System.Process (createPipe) -    pwd <- getCurrentDirectory-    existingEnv <- getEnvironment+runTest+  :: PD.PackageDescription+  -> LBI.LocalBuildInfo+  -> LBI.ComponentLocalBuildInfo+  -> HPCMarkupInfo+  -> TestFlags+  -> PD.TestSuite+  -> IO TestSuiteLog+runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do+  let isCoverageEnabled = LBI.testCoverage lbi+      way = guessWay lbi+      tixDir_ = i $ tixDir distPref way -    let cmd = LBI.buildDir lbi </> testName'-                  </> testName' <.> exeExtension (LBI.hostPlatform lbi)-    -- Check that the test executable exists.-    exists <- doesFileExist cmd-    unless exists $ die' verbosity $ "Error: Could not find test program \"" ++ cmd-                          ++ "\". Did you build the package first?"+  let cmd =+        i (LBI.buildDir lbi)+          </> testName'+          </> testName' <.> exeExtension (LBI.hostPlatform lbi)+  -- Check that the test executable exists.+  exists <- doesFileExist cmd+  unless exists $+    dieWithException verbosity $+      Couldn'tFindTestProgram cmd -    -- Remove old .tix files if appropriate.-    unless (fromFlag $ testKeepTix flags) $ do-        exists' <- doesDirectoryExist tixDir_-        when exists' $ removeDirectoryRecursive tixDir_+  -- Remove old .tix files if appropriate.+  unless (fromFlag $ testKeepTix flags) $ do+    exists' <- doesDirectoryExist tixDir_+    when exists' $ removeDirectoryRecursive tixDir_ -    -- Create directory for HPC files.-    createDirectoryIfMissing True tixDir_+  -- Create directory for HPC files.+  createDirectoryIfMissing True tixDir_ -    -- Write summary notices indicating start of test suite-    notice verbosity $ summarizeSuiteStart $ testName'+  -- Write summary notices indicating start of test suite+  notice verbosity $ summarizeSuiteStart $ testName' +  -- Run the test executable (with the appropriate environment set)+  let progDb = LBI.withPrograms lbi+      pathVar = progSearchPath progDb+      envOverrides = progOverrideEnv progDb+  newPath <- programSearchPathAsPATHVar pathVar+  let opts =+        map+          (testOption pkg_descr lbi suite)+          (testOptions flags)+      tixFile = packageRoot (testCommonFlags flags) </> getSymbolicPath (tixFilePath distPref way (testName')) -    -- Run the test executable-    let opts = map (testOption pkg_descr lbi suite)-                   (testOptions flags)-        dataDirPath = pwd </> PD.dataDir pkg_descr-        tixFile = pwd </> tixFilePath distPref way (testName')-        pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)-                   : existingEnv-        shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv+  shellEnv <-+    getFullEnvironment+      ( [("PATH", Just newPath)]+          ++ [("HPCTIXFILE", Just tixFile) | isCoverageEnabled]+          ++ envOverrides+      ) -    -- Add (DY)LD_LIBRARY_PATH if needed-    shellEnv' <- if LBI.withDynExe lbi-                    then do let (Platform _ os) = LBI.hostPlatform lbi-                            paths <- LBI.depLibraryPaths True False lbi clbi-                            return (addLibraryPath os paths shellEnv)-                    else return shellEnv+  -- Add (DY)LD_LIBRARY_PATH if needed+  shellEnv' <-+    if LBI.withDynExe lbi+      then do+        let (Platform _ os) = LBI.hostPlatform lbi+        paths <- LBI.depLibraryPaths True False lbi clbi+        return (addLibraryPath os paths shellEnv)+      else return shellEnv -    -- Output logger-    (wOut, wErr, getLogText) <- case details of-        Direct -> return (stdout, stderr, return LBS.empty)-        _      -> do-            (rOut, wOut) <- createPipe+  -- Output logger+  (wOut, wErr, getLogText) <- case details of+    Direct -> return (stdout, stderr, return LBS.empty)+    _ -> do+      (rOut, wOut) <- createPipe -            return $ (,,) wOut wOut $ do-                -- Read test executables' output-                logText <- LBS.hGetContents rOut+      return $ (,,) wOut wOut $ do+        -- Read test executables' output+        logText <- LBS.hGetContents rOut -                -- '--show-details=streaming': print the log output in another thread-                when (details == Streaming) $ LBS.putStr logText+        -- '--show-details=streaming': print the log output in another thread+        when (details == Streaming) $ LBS.putStr logText -                -- drain the output.-                evaluate (force logText)+        -- drain the output.+        evaluate (force logText) -    (exit, logText) <- case testWrapper flags of-        Flag path -> rawSystemIOWithEnvAndAction-            verbosity path (cmd:opts) Nothing (Just shellEnv')-            getLogText-            -- these handles are automatically closed-            Nothing (Just wOut) (Just wErr)+  let mbWorkDir =+        interpretSymbolicPathCWD+          <$> flagToMaybe (setupWorkingDir (testCommonFlags flags)) -        NoFlag -> rawSystemIOWithEnvAndAction-            verbosity cmd opts Nothing (Just shellEnv')-            getLogText-            -- these handles are automatically closed-            Nothing (Just wOut) (Just wErr)+  (exit, logText) <- case testWrapper flags of+    Flag path ->+      rawSystemIOWithEnvAndAction+        verbosity+        path+        (cmd : opts)+        mbWorkDir+        (Just shellEnv')+        getLogText+        -- these handles are automatically closed+        Nothing+        (Just wOut)+        (Just wErr)+    NoFlag ->+      rawSystemIOWithEnvAndAction+        verbosity+        cmd+        opts+        mbWorkDir+        (Just shellEnv')+        getLogText+        -- these handles are automatically closed+        Nothing+        (Just wOut)+        (Just wErr) -    -- Generate TestSuiteLog from executable exit code and a machine--    -- readable test log.-    let suiteLog = buildLog exit+  -- Generate TestSuiteLog from executable exit code and a machine-+  -- readable test log.+  let suiteLog = buildLog exit -    -- Write summary notice to log file indicating start of test suite-    appendFile (logFile suiteLog) $ summarizeSuiteStart $ testName'+  -- Write summary notice to log file indicating start of test suite+  appendFile (logFile suiteLog) $ summarizeSuiteStart testName' -    -- Append contents of temporary log file to the final human--    -- readable log file-    LBS.appendFile (logFile suiteLog) logText+  -- Append contents of temporary log file to the final human-+  -- readable log file+  LBS.appendFile (logFile suiteLog) logText -    -- Write end-of-suite summary notice to log file-    appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog+  -- Write end-of-suite summary notice to log file+  appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog -    -- Show the contents of the human-readable log file on the terminal-    -- if there is a failure and/or detailed output is requested-    let whenPrinting = when $-            ( details == Always ||-              details == Failures && not (suitePassed $ testLogs suiteLog))+  -- Show the contents of the human-readable log file on the terminal+  -- if there is a failure and/or detailed output is requested+  let whenPrinting =+        when $+          ( details == Always+              || details == Failures && not (suitePassed $ testLogs suiteLog)+          )             -- verbosity overrides show-details             && verbosity >= normal-    whenPrinting $ do-        LBS.putStr logText-        putChar '\n'+  whenPrinting $ do+    LBS.putStr logText+    putChar '\n' -    -- Write summary notice to terminal indicating end of test suite-    notice verbosity $ summarizeSuiteFinish suiteLog+  -- Write summary notice to terminal indicating end of test suite+  notice verbosity $ summarizeSuiteFinish suiteLog -    when isCoverageEnabled $-        case PD.library pkg_descr of-            Nothing ->-                die' verbosity $ "Error: test coverage is only supported for packages with a library component"+  when isCoverageEnabled $ do+    -- Until #9493 is fixed, we expect cabal-install to pass one dist dir per+    -- library and there being at least one library in the package with the+    -- testsuite.  When it is fixed, we can remove this predicate and allow a+    -- testsuite without a library to cover libraries in other packages of the+    -- same project+    when (null $ PD.allLibraries pkg_descr) $+      dieWithException verbosity TestCoverageSupport -            Just library ->-                markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library+    markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr [suite] -    return suiteLog+  return suiteLog   where+    i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path+    commonFlags = testCommonFlags flags+     testName' = unUnqualComponentName $ PD.testName suite -    distPref = fromFlag $ testDistPref flags-    verbosity = fromFlag $ testVerbosity flags+    distPref = fromFlag $ setupDistPref commonFlags+    verbosity = fromFlag $ setupVerbosity commonFlags     details = fromFlag $ testShowDetails flags-    testLogDir = distPref </> "test"+    testLogDir = distPref </> makeRelativePathEx "test"      buildLog exit =-        let r = case exit of-                    ExitSuccess -> Pass-                    ExitFailure c -> Fail $ "exit code: " ++ show c-            --n = unUnqualComponentName $ PD.testName suite-            l = TestLog-                { testName = testName'-                , testOptionsReturned = []-                , testResult = r-                }-        in TestSuiteLog-                { testSuiteName = PD.testName suite-                , testLogs = l-                , logFile =-                    testLogDir-                    </> testSuiteLogPath (fromFlag $ testHumanLog flags)-                                         pkg_descr lbi testName' l-                }+      let r = case exit of+            ExitSuccess -> Pass+            ExitFailure c -> Fail $ "exit code: " ++ show c+          -- n = unUnqualComponentName $ PD.testName suite+          l =+            TestLog+              { testName = testName'+              , testOptionsReturned = []+              , testResult = r+              }+       in TestSuiteLog+            { testSuiteName = PD.testName suite+            , testLogs = l+            , logFile =+                i testLogDir+                  </> testSuiteLogPath+                    (fromFlag $ testHumanLog flags)+                    pkg_descr+                    lbi+                    testName'+                    l+            }  -- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't -- necessarily a path.-testOption :: PD.PackageDescription-           -> LBI.LocalBuildInfo-           -> PD.TestSuite-           -> PathTemplate-           -> String+testOption+  :: PD.PackageDescription+  -> LBI.LocalBuildInfo+  -> PD.TestSuite+  -> PathTemplate+  -> String testOption pkg_descr lbi suite template =-    fromPathTemplate $ substPathTemplate env template+  fromPathTemplate $ substPathTemplate env template   where-    env = initialPathTemplateEnv-          (PD.package pkg_descr) (LBI.localUnitId lbi)-          (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++-          [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)]+    env =+      initialPathTemplateEnv+        (PD.package pkg_descr)+        (LBI.localUnitId lbi)+        (compilerInfo $ LBI.compiler lbi)+        (LBI.hostPlatform lbi)+        ++ [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)]
src/Distribution/Simple/Test/LibV09.hs view
@@ -1,115 +1,140 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}  module Distribution.Simple.Test.LibV09-       ( runTest-         -- Test stub-       , simpleTestStub-       , stubFilePath, stubMain, stubName, stubWriteLog-       , writeSimpleTestStub-       ) where+  ( runTest+  -- Test stub+  , simpleTestStub+  , stubFilePath+  , stubMain+  , stubName+  , stubWriteLog+  , writeSimpleTestStub+  ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Types.UnqualComponentName+import Prelude () -import Distribution.Compat.CreatePipe-import Distribution.Compat.Environment import Distribution.Compat.Internal.TempFile+import Distribution.Compat.Process (proc) import Distribution.ModuleName import qualified Distribution.PackageDescription as PD-import Distribution.Simple.Build.PathsModule+import Distribution.Pretty import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler+import Distribution.Simple.Errors import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI-import qualified Distribution.Types.LocalBuildInfo as LBI-import Distribution.Simple.Setup+import Distribution.Simple.Program.Db+import Distribution.Simple.Program.Find+import Distribution.Simple.Program.Run+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Test import Distribution.Simple.Test.Log import Distribution.Simple.Utils import Distribution.System import Distribution.TestSuite-import Distribution.Pretty+import qualified Distribution.Types.LocalBuildInfo as LBI+import Distribution.Utils.Path import Distribution.Verbosity  import qualified Control.Exception as CE import qualified Data.ByteString.Lazy as LBS import System.Directory-    ( createDirectoryIfMissing, canonicalizePath-    , doesDirectoryExist, doesFileExist-    , getCurrentDirectory, removeDirectoryRecursive, removeFile-    , setCurrentDirectory )-import System.FilePath ( (</>), (<.>) )-import System.IO ( hClose, hPutStr )-import System.Process (StdStream(..), waitForProcess)--runTest :: PD.PackageDescription-        -> LBI.LocalBuildInfo-        -> LBI.ComponentLocalBuildInfo-        -> TestFlags-        -> PD.TestSuite-        -> IO TestSuiteLog-runTest pkg_descr lbi clbi flags suite = do-    let isCoverageEnabled = LBI.testCoverage lbi-        way = guessWay lbi+  ( canonicalizePath+  , createDirectoryIfMissing+  , doesDirectoryExist+  , doesFileExist+  , getCurrentDirectory+  , removeDirectoryRecursive+  , removeFile+  , setCurrentDirectory+  )+import System.IO (hClose, hPutStr)+import qualified System.Process as Process -    pwd <- getCurrentDirectory-    existingEnv <- getEnvironment+runTest+  :: PD.PackageDescription+  -> LBI.LocalBuildInfo+  -> LBI.ComponentLocalBuildInfo+  -> HPCMarkupInfo+  -> TestFlags+  -> PD.TestSuite+  -> IO TestSuiteLog+runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do+  let isCoverageEnabled = LBI.testCoverage lbi+      way = guessWay lbi -    let cmd = LBI.buildDir lbi </> stubName suite-                  </> stubName suite <.> exeExtension (LBI.hostPlatform lbi)-    -- Check that the test executable exists.-    exists <- doesFileExist cmd-    unless exists $-      die' verbosity $ "Error: Could not find test program \"" ++ cmd-                    ++ "\". Did you build the package first?"+  let mbWorkDir = LBI.mbWorkDirLBI lbi -    -- Remove old .tix files if appropriate.-    unless (fromFlag $ testKeepTix flags) $ do-        let tDir = tixDir distPref way testName'-        exists' <- doesDirectoryExist tDir-        when exists' $ removeDirectoryRecursive tDir+  let cmd =+        interpretSymbolicPath mbWorkDir (LBI.buildDir lbi)+          </> stubName suite+          </> stubName suite <.> exeExtension (LBI.hostPlatform lbi)+      tDir = i $ tixDir distPref way+  -- Check that the test executable exists.+  exists <- doesFileExist cmd+  unless exists $+    dieWithException verbosity $+      Couldn'tFindTestProgLibV09 cmd -    -- Create directory for HPC files.-    createDirectoryIfMissing True $ tixDir distPref way testName'+  -- Remove old .tix files if appropriate.+  unless (fromFlag $ testKeepTix flags) $ do+    exists' <- doesDirectoryExist tDir+    when exists' $ removeDirectoryRecursive tDir -    -- Write summary notices indicating start of test suite-    notice verbosity $ summarizeSuiteStart testName'+  -- Create directory for HPC files.+  createDirectoryIfMissing True tDir -    suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do+  -- Write summary notices indicating start of test suite+  notice verbosity $ summarizeSuiteStart testName' -        -- TODO: this setup is broken,-        -- if the test output is too big, we will deadlock.-        (rOut, wOut) <- createPipe+  suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do+    -- Compute the appropriate environment for running the test suite+    let progDb = LBI.withPrograms lbi+        pathVar = progSearchPath progDb+        envOverrides = progOverrideEnv progDb+    newPath <- programSearchPathAsPATHVar pathVar -        -- Run test executable-        (Just wIn, _, _, process) <- do-                let opts = map (testOption pkg_descr lbi suite) $ testOptions flags-                    dataDirPath = pwd </> PD.dataDir pkg_descr-                    tixFile = pwd </> tixFilePath distPref way testName'-                    pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)-                               : existingEnv-                    shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled]-                             ++ pkgPathEnv-                -- Add (DY)LD_LIBRARY_PATH if needed-                shellEnv' <--                  if LBI.withDynExe lbi-                  then do-                    let (Platform _ os) = LBI.hostPlatform lbi-                    paths <- LBI.depLibraryPaths True False lbi clbi-                    cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi-                    return (addLibraryPath os (cpath : paths) shellEnv)-                  else return shellEnv-                case testWrapper flags of-                  Flag path -> createProcessWithEnv verbosity path (cmd:opts) Nothing (Just shellEnv')-                               -- these handles are closed automatically-                               CreatePipe (UseHandle wOut) (UseHandle wOut)+    -- Run test executable+    let opts = map (testOption pkg_descr lbi suite) $ testOptions flags+        tixFile = i $ tixFilePath distPref way testName' -                  NoFlag -> createProcessWithEnv verbosity cmd opts Nothing (Just shellEnv')-                            -- these handles are closed automatically-                            CreatePipe (UseHandle wOut) (UseHandle wOut)+    shellEnv <-+      getFullEnvironment+        ( [("PATH", Just newPath)]+            ++ [("HPCTIXFILE", Just tixFile) | isCoverageEnabled]+            ++ envOverrides+        )+    -- Add (DY)LD_LIBRARY_PATH if needed+    shellEnv' <-+      if LBI.withDynExe lbi+        then do+          let (Platform _ os) = LBI.hostPlatform lbi+          paths <- LBI.depLibraryPaths True False lbi clbi+          cpath <- canonicalizePath $ i $ LBI.componentBuildDir lbi clbi+          return (addLibraryPath os (cpath : paths) shellEnv)+        else return shellEnv+    let (cmd', opts') = case testWrapper flags of+          Flag path -> (path, cmd : opts)+          NoFlag -> (cmd, opts) +    -- TODO: this setup is broken,+    -- if the test output is too big, we will deadlock.+    (rOut, wOut) <- Process.createPipe+    (exitcode, logText) <- rawSystemProcAction+      verbosity+      (proc cmd' opts')+        { Process.env = Just shellEnv'+        , Process.std_in = Process.CreatePipe+        , Process.std_out = Process.UseHandle wOut+        , Process.std_err = Process.UseHandle wOut+        }+      $ \mIn _ _ -> do+        let wIn = fromCreatePipe mIn         hPutStr wIn $ show (tempLog, PD.testName suite)         hClose wIn @@ -118,112 +143,132 @@         logText <- LBS.hGetContents rOut         -- Force the IO manager to drain the test output pipe         _ <- evaluate (force logText)--        exitcode <- waitForProcess process-        unless (exitcode == ExitSuccess) $ do-            debug verbosity $ cmd ++ " returned " ++ show exitcode+        return logText+    unless (exitcode == ExitSuccess) $+      debug verbosity $+        cmd ++ " returned " ++ show exitcode -        -- Generate final log file name-        let finalLogName l = testLogDir-                             </> testSuiteLogPath-                                 (fromFlag $ testHumanLog flags) pkg_descr lbi-                                 (unUnqualComponentName $ testSuiteName l) (testLogs l)-        -- Generate TestSuiteLog from executable exit code and a machine--        -- readable test log-        suiteLog <- fmap (\s -> (\l -> l { logFile = finalLogName l })-                    . fromMaybe (error $ "panic! read @TestSuiteLog " ++ show s) $ readMaybe s) -- TODO: eradicateNoParse-                    $ readFile tempLog+    -- Generate final log file name+    let finalLogName l =+          interpretSymbolicPath mbWorkDir testLogDir+            </> testSuiteLogPath+              (fromFlag $ testHumanLog flags)+              pkg_descr+              lbi+              (unUnqualComponentName $ testSuiteName l)+              (testLogs l)+    -- Generate TestSuiteLog from executable exit code and a machine-+    -- readable test log+    suiteLog <-+      fmap+        ( \s ->+            (\l -> l{logFile = finalLogName l})+              . fromMaybe (error $ "panic! read @TestSuiteLog " ++ show s)+              $ readMaybe s -- TODO: eradicateNoParse+        )+        $ readFile tempLog -        -- Write summary notice to log file indicating start of test suite-        appendFile (logFile suiteLog) $ summarizeSuiteStart testName'+    -- Write summary notice to log file indicating start of test suite+    appendFile (logFile suiteLog) $ summarizeSuiteStart testName' -        LBS.appendFile (logFile suiteLog) logText+    LBS.appendFile (logFile suiteLog) logText -        -- Write end-of-suite summary notice to log file-        appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog+    -- Write end-of-suite summary notice to log file+    appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog -        -- Show the contents of the human-readable log file on the terminal-        -- if there is a failure and/or detailed output is requested-        let details = fromFlag $ testShowDetails flags-            whenPrinting = when $ (details > Never)-                && (not (suitePassed $ testLogs suiteLog) || details == Always)-                && verbosity >= normal-        whenPrinting $ do-            LBS.putStr logText-            putChar '\n'+    -- Show the contents of the human-readable log file on the terminal+    -- if there is a failure and/or detailed output is requested+    let details = fromFlag $ testShowDetails flags+        whenPrinting =+          when $+            (details > Never)+              && (not (suitePassed $ testLogs suiteLog) || details == Always)+              && verbosity >= normal+    whenPrinting $ do+      LBS.putStr logText+      putChar '\n' -        return suiteLog+    return suiteLog -    -- Write summary notice to terminal indicating end of test suite-    notice verbosity $ summarizeSuiteFinish suiteLog+  -- Write summary notice to terminal indicating end of test suite+  notice verbosity $ summarizeSuiteFinish suiteLog -    when isCoverageEnabled $-        case PD.library pkg_descr of-            Nothing ->-                die' verbosity $ "Error: test coverage is only supported for packages with a library component"+  when isCoverageEnabled $ do+    -- Until #9493 is fixed, we expect cabal-install to pass one dist dir per+    -- library and there being at least one library in the package with the+    -- testsuite.  When it is fixed, we can remove this predicate and allow a+    -- testsuite without a library to cover libraries in other packages of the+    -- same project+    when (null $ PD.allLibraries pkg_descr) $+      dieWithException verbosity TestCoverageSupport -            Just library ->-                markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library+    markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr [suite] -    return suiteLog+  return suiteLog   where+    i = LBI.interpretSymbolicPathLBI lbi+    common = testCommonFlags flags     testName' = unUnqualComponentName $ PD.testName suite      deleteIfExists file = do-        exists <- doesFileExist file-        when exists $ removeFile file+      exists <- doesFileExist file+      when exists $ removeFile file -    testLogDir = distPref </> "test"+    testLogDir = distPref </> makeRelativePathEx "test"     openCabalTemp = do-        (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log"-        hClose h >> return f+      (f, h) <- openTempFile (i testLogDir) $ "cabal-test-" <.> "log"+      hClose h >> return f -    distPref = fromFlag $ testDistPref flags-    verbosity = fromFlag $ testVerbosity flags+    distPref = fromFlag $ setupDistPref common+    verbosity = fromFlag $ setupVerbosity common  -- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't -- necessarily a path.-testOption :: PD.PackageDescription-           -> LBI.LocalBuildInfo-           -> PD.TestSuite-           -> PathTemplate-           -> String+testOption+  :: PD.PackageDescription+  -> LBI.LocalBuildInfo+  -> PD.TestSuite+  -> PathTemplate+  -> String testOption pkg_descr lbi suite template =-    fromPathTemplate $ substPathTemplate env template+  fromPathTemplate $ substPathTemplate env template   where-    env = initialPathTemplateEnv-          (PD.package pkg_descr) (LBI.localUnitId lbi)-          (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++-          [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)]+    env =+      initialPathTemplateEnv+        (PD.package pkg_descr)+        (LBI.localUnitId lbi)+        (compilerInfo $ LBI.compiler lbi)+        (LBI.hostPlatform lbi)+        ++ [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)]  -- Test stub ---------- --- | The name of the stub executable associated with a library 'TestSuite'.-stubName :: PD.TestSuite -> FilePath-stubName t = unUnqualComponentName (PD.testName t) ++ "Stub"- -- | The filename of the source file for the stub executable associated with a -- library 'TestSuite'. stubFilePath :: PD.TestSuite -> FilePath stubFilePath t = stubName t <.> "hs"  -- | Write the source file for a library 'TestSuite' stub executable.-writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub-                                    -- is being created-                    -> FilePath     -- ^ path to directory where stub source-                                    -- should be located-                    -> IO ()+writeSimpleTestStub+  :: PD.TestSuite+  -- ^ library 'TestSuite' for which a stub+  -- is being created+  -> FilePath+  -- ^ path to directory where stub source+  -- should be located+  -> IO () writeSimpleTestStub t dir = do-    createDirectoryIfMissing True dir-    let filename = dir </> stubFilePath t-        m = case PD.testInterface t of-            PD.TestSuiteLibV09 _  m' -> m'-            _                        -> error "writeSimpleTestStub: invalid TestSuite passed"-    writeFile filename $ simpleTestStub m+  createDirectoryIfMissing True dir+  let filename = dir </> stubFilePath t+      m = case PD.testInterface t of+        PD.TestSuiteLibV09 _ m' -> m'+        _ -> error "writeSimpleTestStub: invalid TestSuite passed"+  writeFile filename $ simpleTestStub m  -- | Source code for library test suite stub executable simpleTestStub :: ModuleName -> String-simpleTestStub m = unlines+simpleTestStub m =+  unlines     [ "module Main ( main ) where"     , "import Distribution.Simple.Test.LibV09 ( stubMain )"     , "import " ++ show (pretty m) ++ " ( tests )"@@ -236,18 +281,22 @@ -- of detectable errors when Cabal is compiled. stubMain :: IO [Test] -> IO () stubMain tests = do-    (f, n) <- fmap (\s -> fromMaybe (error $ "panic! read " ++ show s) $ readMaybe s) getContents -- TODO: eradicateNoParse-    dir <- getCurrentDirectory-    results <- (tests >>= stubRunTests) `CE.catch` errHandler-    setCurrentDirectory dir-    stubWriteLog f n results+  (f, n) <- fmap (\s -> fromMaybe (error $ "panic! read " ++ show s) $ readMaybe s) getContents -- TODO: eradicateNoParse+  dir <- getCurrentDirectory+  results <- (tests >>= stubRunTests) `CE.catch` errHandler+  setCurrentDirectory dir+  stubWriteLog f n results   where     errHandler :: CE.SomeException -> IO TestLogs     errHandler e = case CE.fromException e of-        Just CE.UserInterrupt -> CE.throwIO e-        _ -> return $ TestLog { testName = "Cabal test suite exception",-                                testOptionsReturned = [],-                                testResult = Error $ show e }+      Just CE.UserInterrupt -> CE.throwIO e+      _ ->+        return $+          TestLog+            { testName = "Cabal test suite exception"+            , testOptionsReturned = []+            , testResult = Error $ show e+            }  -- | The test runner used in library "TestSuite" stub executables.  Runs a list -- of 'Test's.  An executable calling this function is meant to be invoked as@@ -258,35 +307,36 @@ -- by the calling Cabal process. stubRunTests :: [Test] -> IO TestLogs stubRunTests tests = do-    logs <- traverse stubRunTests' tests-    return $ GroupLogs "Default" logs+  logs <- traverse stubRunTests' tests+  return $ GroupLogs "Default" logs   where     stubRunTests' (Test t) = do-        l <- run t >>= finish-        summarizeTest normal Always l-        return l+      l <- run t >>= finish+      summarizeTest normal Always l+      return l       where         finish (Finished result) =-            return TestLog-                { testName = name t-                , testOptionsReturned = defaultOptions t-                , testResult = result-                }+          return+            TestLog+              { testName = name t+              , testOptionsReturned = defaultOptions t+              , testResult = result+              }         finish (Progress _ next) = next >>= finish-    stubRunTests' g@(Group {}) = do-        logs <- traverse stubRunTests' $ groupTests g-        return $ GroupLogs (groupName g) logs+    stubRunTests' g@(Group{}) = do+      logs <- traverse stubRunTests' $ groupTests g+      return $ GroupLogs (groupName g) logs     stubRunTests' (ExtraOptions _ t) = stubRunTests' t     maybeDefaultOption opt =-        maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt+      maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt     defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst  -- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling -- Cabal process to read. stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> IO () stubWriteLog f n logs = do-    let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f }-    writeFile (logFile testLog) $ show testLog-    when (suiteError logs) $ exitWith $ ExitFailure 2-    when (suiteFailed logs) $ exitWith $ ExitFailure 1-    exitSuccess+  let testLog = TestSuiteLog{testSuiteName = n, testLogs = logs, logFile = f}+  writeFile (logFile testLog) $ show testLog+  when (suiteError logs) $ exitWith $ ExitFailure 2+  when (suiteFailed logs) $ exitWith $ ExitFailure 1+  exitSuccess
src/Distribution/Simple/Test/Log.hs view
@@ -2,49 +2,53 @@ {-# LANGUAGE RankNTypes #-}  module Distribution.Simple.Test.Log-       ( PackageLog(..)-       , TestLogs(..)-       , TestSuiteLog(..)-       , countTestResults-       , localPackageLog-       , summarizePackage-       , summarizeSuiteFinish, summarizeSuiteStart-       , summarizeTest-       , suiteError, suiteFailed, suitePassed-       , testSuiteLogPath-       ) where+  ( PackageLog (..)+  , TestLogs (..)+  , TestSuiteLog (..)+  , countTestResults+  , localPackageLog+  , summarizePackage+  , summarizeSuiteFinish+  , summarizeSuiteStart+  , summarizeTest+  , suiteError+  , suiteFailed+  , suitePassed+  , testSuiteLogPath+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import Distribution.Package-import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD+import Distribution.Pretty import Distribution.Simple.Compiler import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI-import Distribution.Simple.Setup+import Distribution.Simple.Setup.Test (TestShowDetails (Always, Never)) import Distribution.Simple.Utils import Distribution.System import Distribution.TestSuite+import Distribution.Types.UnqualComponentName import Distribution.Verbosity-import Distribution.Pretty  import qualified Prelude (foldl1)  -- | Logs all test results for a package, broken down first by test suite and -- then by test case. data PackageLog = PackageLog-    { package :: PackageId-    , compiler :: CompilerId-    , platform :: Platform-    , testSuites :: [TestSuiteLog]-    }-    deriving (Read, Show, Eq)+  { package :: PackageId+  , compiler :: CompilerId+  , platform :: Platform+  , testSuites :: [TestSuiteLog]+  }+  deriving (Read, Show, Eq)  -- | A 'PackageLog' with package and platform information specified. localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog-localPackageLog pkg_descr lbi = PackageLog+localPackageLog pkg_descr lbi =+  PackageLog     { package = PD.package pkg_descr     , compiler = compilerId $ LBI.compiler lbi     , platform = LBI.hostPlatform lbi@@ -53,114 +57,137 @@  -- | Logs test suite results, itemized by test case. data TestSuiteLog = TestSuiteLog-    { testSuiteName :: UnqualComponentName-    , testLogs :: TestLogs-    , logFile :: FilePath    -- path to human-readable log file-    }-    deriving (Read, Show, Eq)+  { testSuiteName :: UnqualComponentName+  , testLogs :: TestLogs+  , logFile :: FilePath -- path to human-readable log file+  }+  deriving (Read, Show, Eq)  data TestLogs-    = TestLog-        { testName              :: String-        , testOptionsReturned   :: Options-        , testResult            :: Result-        }-    | GroupLogs String [TestLogs]-    deriving (Read, Show, Eq)+  = TestLog+      { testName :: String+      , testOptionsReturned :: Options+      , testResult :: Result+      }+  | GroupLogs String [TestLogs]+  deriving (Read, Show, Eq)  -- | Count the number of pass, fail, and error test results in a 'TestLogs' -- tree.-countTestResults :: TestLogs-                 -> (Int, Int, Int) -- ^ Passes, fails, and errors,-                                    -- respectively.+countTestResults+  :: TestLogs+  -> (Int, Int, Int)+  -- ^ Passes, fails, and errors,+  -- respectively. countTestResults = go (0, 0, 0)   where-    go (p, f, e) (TestLog { testResult = r }) =-        case r of-            Pass -> (p + 1, f, e)-            Fail _ -> (p, f + 1, e)-            Error _ -> (p, f, e + 1)+    go (p, f, e) (TestLog{testResult = r}) =+      case r of+        Pass -> (p + 1, f, e)+        Fail _ -> (p, f + 1, e)+        Error _ -> (p, f, e + 1)     go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts  -- | From a 'TestSuiteLog', determine if the test suite passed. suitePassed :: TestLogs -> Bool suitePassed l =-    case countTestResults l of-        (_, 0, 0) -> True-        _ -> False+  case countTestResults l of+    (_, 0, 0) -> True+    _ -> False  -- | From a 'TestSuiteLog', determine if the test suite failed. suiteFailed :: TestLogs -> Bool suiteFailed l =-    case countTestResults l of-        (_, 0, _) -> False-        _ -> True+  case countTestResults l of+    (_, 0, _) -> False+    _ -> True  -- | From a 'TestSuiteLog', determine if the test suite encountered errors. suiteError :: TestLogs -> Bool suiteError l =-    case countTestResults l of-        (_, _, 0) -> False-        _ -> True+  case countTestResults l of+    (_, _, 0) -> False+    _ -> True  resultString :: TestLogs -> String-resultString l | suiteError l = "error"-               | suiteFailed l = "fail"-               | otherwise = "pass"+resultString l+  | suiteError l = "error"+  | suiteFailed l = "fail"+  | otherwise = "pass" -testSuiteLogPath :: PathTemplate-                 -> PD.PackageDescription-                 -> LBI.LocalBuildInfo-                 -> String -- ^ test suite name-                 -> TestLogs -- ^ test suite results-                 -> FilePath+testSuiteLogPath+  :: PathTemplate+  -> PD.PackageDescription+  -> LBI.LocalBuildInfo+  -> String+  -- ^ test suite name+  -> TestLogs+  -- ^ test suite results+  -> FilePath testSuiteLogPath template pkg_descr lbi test_name result =-    fromPathTemplate $ substPathTemplate env template-    where-        env = initialPathTemplateEnv-                (PD.package pkg_descr) (LBI.localUnitId lbi)-                (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi)-                ++  [ (TestSuiteNameVar, toPathTemplate test_name)-                    , (TestSuiteResultVar, toPathTemplate $ resultString result)-                    ]+  fromPathTemplate $ substPathTemplate env template+  where+    env =+      initialPathTemplateEnv+        (PD.package pkg_descr)+        (LBI.localUnitId lbi)+        (compilerInfo $ LBI.compiler lbi)+        (LBI.hostPlatform lbi)+        ++ [ (TestSuiteNameVar, toPathTemplate test_name)+           , (TestSuiteResultVar, toPathTemplate $ resultString result)+           ]  -- | Print a summary to the console after all test suites have been run -- indicating the number of successful test suites and cases.  Returns 'True' if -- all test suites passed and 'False' otherwise. summarizePackage :: Verbosity -> PackageLog -> IO Bool summarizePackage verbosity packageLog = do-    let counts = map (countTestResults . testLogs) $ testSuites packageLog-        (passed, failed, errors) = Prelude.foldl1 addTriple counts-        totalCases = passed + failed + errors-        passedSuites = length-                       $ filter (suitePassed . testLogs)-                       $ testSuites packageLog-        totalSuites = length $ testSuites packageLog-    notice verbosity $ show passedSuites ++ " of " ++ show totalSuites-        ++ " test suites (" ++ show passed ++ " of "-        ++ show totalCases ++ " test cases) passed."-    return $! passedSuites == totalSuites+  let counts = map (countTestResults . testLogs) $ testSuites packageLog+      (passed, failed, errors) = Prelude.foldl1 addTriple counts+      totalCases = passed + failed + errors+      passedSuites =+        length $+          filter (suitePassed . testLogs) $+            testSuites packageLog+      totalSuites = length $ testSuites packageLog+  notice verbosity $+    show passedSuites+      ++ " of "+      ++ show totalSuites+      ++ " test suites ("+      ++ show passed+      ++ " of "+      ++ show totalCases+      ++ " test cases) passed."+  return $! passedSuites == totalSuites   where     addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2)  -- | Print a summary of a single test case's result to the console, suppressing -- output for certain verbosity or test filter levels. summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO ()-summarizeTest _ _ (GroupLogs {}) = return ()+summarizeTest _ _ (GroupLogs{}) = return () summarizeTest verbosity details t =-    when shouldPrint $ notice verbosity $ "Test case " ++ testName t-        ++ ": " ++ show (testResult t)-    where shouldPrint = (details > Never) && (notPassed || details == Always)-          notPassed = testResult t /= Pass+  when shouldPrint $+    notice verbosity $+      "Test case "+        ++ testName t+        ++ ": "+        ++ show (testResult t)+  where+    shouldPrint = (details > Never) && (notPassed || details == Always)+    notPassed = testResult t /= Pass  -- | Print a summary of the test suite's results on the console, suppressing -- output for certain verbosity or test filter levels. summarizeSuiteFinish :: TestSuiteLog -> String-summarizeSuiteFinish testLog = unlines+summarizeSuiteFinish testLog =+  unlines     [ "Test suite " ++ prettyShow (testSuiteName testLog) ++ ": " ++ resStr     , "Test suite logged to: " ++ logFile testLog     ]-    where resStr = map toUpper (resultString $ testLogs testLog)+  where+    resStr = map toUpper (resultString $ testLogs testLog)  summarizeSuiteStart :: String -> String summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n"
src/Distribution/Simple/UHC.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.UHC -- Copyright   :  Andres Loeh 2009@@ -16,57 +18,66 @@ -- Thanks to the authors of the other implementation-specific files, in -- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for -- inspiration on how to design this module.--module Distribution.Simple.UHC (-    configure, getInstalledPackages,-    buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath+module Distribution.Simple.UHC+  ( configure+  , getInstalledPackages+  , buildLib+  , buildExe+  , installLib+  , registerPackage+  , inplacePackageDbPath   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import Distribution.InstalledPackageInfo import Distribution.Package hiding (installedUnitId) import Distribution.PackageDescription+import Distribution.Parsec+import Distribution.Pretty import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex import Distribution.Simple.Program import Distribution.Simple.Utils-import Distribution.Pretty-import Distribution.Parsec+import Distribution.System import Distribution.Types.MungedPackageId+import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version-import Distribution.System import Language.Haskell.Extension-import Distribution.Utils.Path -import qualified Data.Map as Map ( empty )+import qualified Data.Map as Map (empty) import System.Directory-import System.FilePath+import System.FilePath (pathSeparator)  -- ----------------------------------------------------------------------------- -- Configuring -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb)-configure verbosity hcPath _hcPkgPath progdb = do-+configure+  :: Verbosity+  -> Maybe FilePath+  -> ProgramDb+  -> IO (Compiler, Maybe Platform, ProgramDb)+configure verbosity hcPath progdb = do   (_uhcProg, uhcVersion, progdb') <--    requireProgramVersion verbosity uhcProgram-    (orLaterVersion (mkVersion [1,0,2]))-    (userMaybeSpecifyPath "uhc" hcPath progdb)+    requireProgramVersion+      verbosity+      uhcProgram+      (orLaterVersion (mkVersion [1, 0, 2]))+      (userMaybeSpecifyPath "uhc" hcPath progdb) -  let comp = Compiler {-               compilerId         =  CompilerId UHC uhcVersion,-               compilerAbiTag     =  NoAbiTag,-               compilerCompat     =  [],-               compilerLanguages  =  uhcLanguages,-               compilerExtensions =  uhcLanguageExtensions,-               compilerProperties =  Map.empty-             }+  let comp =+        Compiler+          { compilerId = CompilerId UHC uhcVersion+          , compilerAbiTag = NoAbiTag+          , compilerCompat = []+          , compilerLanguages = uhcLanguages+          , compilerExtensions = uhcLanguageExtensions+          , compilerProperties = Map.empty+          }       compPlatform = Nothing   return (comp, compPlatform, progdb') @@ -76,64 +87,84 @@ -- | The flags for the supported extensions. uhcLanguageExtensions :: [(Extension, Maybe CompilerFlag)] uhcLanguageExtensions =-    let doFlag (f, (enable, disable)) = [(EnableExtension  f, enable),-                                         (DisableExtension f, disable)]-        alwaysOn = (Nothing, Nothing{- wrong -})-    in concatMap doFlag-    [(CPP,                          (Just "--cpp", Nothing{- wrong -})),-     (PolymorphicComponents,        alwaysOn),-     (ExistentialQuantification,    alwaysOn),-     (ForeignFunctionInterface,     alwaysOn),-     (UndecidableInstances,         alwaysOn),-     (MultiParamTypeClasses,        alwaysOn),-     (Rank2Types,                   alwaysOn),-     (PatternSignatures,            alwaysOn),-     (EmptyDataDecls,               alwaysOn),-     (ImplicitPrelude,              (Nothing, Just "--no-prelude"{- wrong -})),-     (TypeOperators,                alwaysOn),-     (OverlappingInstances,         alwaysOn),-     (FlexibleInstances,            alwaysOn)]+  let doFlag (f, (enable, disable)) =+        [ (EnableExtension f, enable)+        , (DisableExtension f, disable)+        ]+      alwaysOn = (Nothing, Nothing {- wrong -})+   in concatMap+        doFlag+        [ (CPP, (Just "--cpp", Nothing {- wrong -}))+        , (PolymorphicComponents, alwaysOn)+        , (ExistentialQuantification, alwaysOn)+        , (ForeignFunctionInterface, alwaysOn)+        , (UndecidableInstances, alwaysOn)+        , (MultiParamTypeClasses, alwaysOn)+        , (Rank2Types, alwaysOn)+        , (PatternSignatures, alwaysOn)+        , (EmptyDataDecls, alwaysOn)+        , (ImplicitPrelude, (Nothing, Just "--no-prelude" {- wrong -}))+        , (TypeOperators, alwaysOn)+        , (OverlappingInstances, alwaysOn)+        , (FlexibleInstances, alwaysOn)+        ] -getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramDb-                     -> IO InstalledPackageIndex-getInstalledPackages verbosity comp packagedbs progdb = do+getInstalledPackages+  :: Verbosity+  -> Compiler+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBStackX (SymbolicPath from (Dir PkgDB))+  -> ProgramDb+  -> IO InstalledPackageIndex+getInstalledPackages verbosity comp mbWorkDir packagedbs progdb = do   let compilerid = compilerId comp   systemPkgDir <- getGlobalPackageDir verbosity progdb-  userPkgDir   <- getUserPackageDir-  let pkgDirs    = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs)+  userPkgDir <- getUserPackageDir+  let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir mbWorkDir) packagedbs)   -- putStrLn $ "pkgdirs: " ++ show pkgDirs-  pkgs <- liftM (map addBuiltinVersions . concat) $-          traverse (\ d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d))-          pkgDirs+  pkgs <-+    liftM (map addBuiltinVersions . concat) $+      traverse+        (\d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d))+        pkgDirs   -- putStrLn $ "pkgs: " ++ show pkgs   let iPkgs =         map mkInstalledPackageInfo $-        concatMap parsePackage $-        pkgs+          concatMap parsePackage $+            pkgs   -- putStrLn $ "installed pkgs: " ++ show iPkgs   return (fromList iPkgs)  getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath getGlobalPackageDir verbosity progdb = do-    output <- getDbProgramOutput verbosity-                uhcProgram progdb ["--meta-pkgdir-system"]-    -- we need to trim because pkgdir contains an extra newline at the end-    let pkgdir = trimEnd output-    return pkgdir+  output <-+    getDbProgramOutput+      verbosity+      uhcProgram+      progdb+      ["--meta-pkgdir-system"]+  -- we need to trim because pkgdir contains an extra newline at the end+  let pkgdir = trimEnd output+  return pkgdir   where-    trimEnd = reverse . dropWhile isSpace . reverse+    trimEnd = dropWhileEnd isSpace  getUserPackageDir :: IO FilePath getUserPackageDir = do-    homeDir <- getHomeDirectory-    return $ homeDir </> ".cabal" </> "lib"  -- TODO: determine in some other way+  homeDir <- getHomeDirectory+  return $ homeDir </> ".cabal" </> "lib" -- TODO: determine in some other way -packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]-packageDbPaths user system db =+packageDbPaths+  :: FilePath+  -> FilePath+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBX (SymbolicPath from (Dir PkgDB))+  -> [FilePath]+packageDbPaths user system mbWorkDir db =   case db of-    GlobalPackageDB         ->  [ system ]-    UserPackageDB           ->  [ user ]-    SpecificPackageDB path  ->  [ path ]+    GlobalPackageDB -> [system]+    UserPackageDB -> [user]+    SpecificPackageDB path -> [interpretSymbolicPath mbWorkDir path]  -- | Hack to add version numbers to UHC-built-in packages. This should sooner or -- later be fixed on the UHC side.@@ -143,7 +174,7 @@ addBuiltinVersions "base"  = "base-3.0" addBuiltinVersions "array" = "array-0.2" -}-addBuiltinVersions xs      = xs+addBuiltinVersions xs = xs  -- | Name of the installed package config file. installedPkgConfig :: String@@ -153,144 +184,194 @@ -- looking only for the presence of an installed package configuration. -- TODO: Actually make use of the information provided in the file. isPkgDir :: String -> String -> String -> IO Bool-isPkgDir _ _   ('.' : _)  = return False  -- ignore files starting with a .-isPkgDir c dir xs         = do-                              let candidate = dir </> uhcPackageDir xs c-                              -- putStrLn $ "trying: " ++ candidate-                              doesFileExist (candidate </> installedPkgConfig)+isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a .+isPkgDir c dir xs = do+  let candidate = dir </> uhcPackageDir xs c+  -- putStrLn $ "trying: " ++ candidate+  doesFileExist (candidate </> installedPkgConfig)  parsePackage :: String -> [PackageId]-parsePackage = toList  . simpleParsec+parsePackage = toList . simpleParsec  -- | Create a trivial package info from a directory name. mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo-mkInstalledPackageInfo p = emptyInstalledPackageInfo-  { installedUnitId = mkLegacyUnitId p,-    sourcePackageId = p }-+mkInstalledPackageInfo p =+  emptyInstalledPackageInfo+    { installedUnitId = mkLegacyUnitId p+    , sourcePackageId = p+    }  -- ----------------------------------------------------------------------------- -- Building -buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()+buildLib+  :: Verbosity+  -> PackageDescription+  -> LocalBuildInfo+  -> Library+  -> ComponentLocalBuildInfo+  -> IO () buildLib verbosity pkg_descr lbi lib clbi = do-   systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)-  userPkgDir   <- getUserPackageDir-  let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)-  let uhcArgs =    -- set package name-                   ["--pkg-build=" ++ prettyShow (packageId pkg_descr)]-                   -- common flags lib/exe-                ++ constructUHCCmdLine userPkgDir systemPkgDir-                                       lbi (libBuildInfo lib) clbi-                                       (buildDir lbi) verbosity-                   -- source files-                   -- suboptimal: UHC does not understand module names, so-                   -- we replace periods by path separators-                ++ map (map (\ c -> if c == '.' then pathSeparator else c))-                       (map prettyShow (allLibModules lib clbi))+  userPkgDir <- getUserPackageDir+  let runUhcProg = runDbProgramCwd verbosity (mbWorkDirLBI lbi) uhcProgram (withPrograms lbi)+  let uhcArgs =+        -- set package name+        ["--pkg-build=" ++ prettyShow (packageId pkg_descr)]+          -- common flags lib/exe+          ++ constructUHCCmdLine+            userPkgDir+            systemPkgDir+            lbi+            (libBuildInfo lib)+            clbi+            (buildDir lbi)+            verbosity+          -- source files+          -- suboptimal: UHC does not understand module names, so+          -- we replace periods by path separators+          ++ map+            (map (\c -> if c == '.' then pathSeparator else c))+            (map prettyShow (allLibModules lib clbi))    runUhcProg uhcArgs    return () -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()+buildExe+  :: Verbosity+  -> PackageDescription+  -> LocalBuildInfo+  -> Executable+  -> ComponentLocalBuildInfo+  -> IO () buildExe verbosity _pkg_descr lbi exe clbi = do   systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)-  userPkgDir   <- getUserPackageDir-  let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)-  let uhcArgs =    -- common flags lib/exe-                   constructUHCCmdLine userPkgDir systemPkgDir-                                       lbi (buildInfo exe) clbi-                                       (buildDir lbi) verbosity-                   -- output file-                ++ ["--output", buildDir lbi </> prettyShow (exeName exe)]-                   -- main source module-                ++ [modulePath exe]+  userPkgDir <- getUserPackageDir+  let mbWorkDir = mbWorkDirLBI lbi+  srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs $ buildInfo exe) (modulePath exe)+  let runUhcProg = runDbProgramCwd verbosity (mbWorkDirLBI lbi) uhcProgram (withPrograms lbi)+      u = interpretSymbolicPathCWD+      uhcArgs =+        -- common flags lib/exe+        constructUHCCmdLine+          userPkgDir+          systemPkgDir+          lbi+          (buildInfo exe)+          clbi+          (buildDir lbi)+          verbosity+          -- output file+          ++ ["--output", u $ buildDir lbi </> makeRelativePathEx (prettyShow (exeName exe))]+          -- main source module+          ++ [u $ srcMainPath]   runUhcProg uhcArgs -constructUHCCmdLine :: FilePath -> FilePath-                    -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo-                    -> FilePath -> Verbosity -> [String]+constructUHCCmdLine+  :: FilePath+  -> FilePath+  -> LocalBuildInfo+  -> BuildInfo+  -> ComponentLocalBuildInfo+  -> SymbolicPath Pkg (Dir Build)+  -> Verbosity+  -> [String] constructUHCCmdLine user system lbi bi clbi odir verbosity =-     -- verbosity-     (if      verbosity >= deafening then ["-v4"]-      else if verbosity >= normal    then []-      else                                ["-v0"])-  ++ hcOptions UHC bi-     -- flags for language extensions-  ++ languageToFlags   (compiler lbi) (defaultLanguage bi)-  ++ extensionsToFlags (compiler lbi) (usedExtensions bi)-     -- packages-  ++ ["--hide-all-packages"]-  ++ uhcPackageDbOptions user system (withPackageDB lbi)-  ++ ["--package=uhcbase"]-  ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi ]-     -- search paths-  ++ ["-i" ++ odir]-  ++ ["-i" ++ getSymbolicPath l | l <- nub (hsSourceDirs bi)]-  ++ ["-i" ++ autogenComponentModulesDir lbi clbi]-  ++ ["-i" ++ autogenPackageModulesDir lbi]-     -- cpp options-  ++ ["--optP=" ++ opt | opt <- cppOptions bi]-     -- output path-  ++ ["--odir=" ++ odir]-     -- optimization-  ++ (case withOptimization lbi of-        NoOptimisation       ->  ["-O0"]-        NormalOptimisation   ->  ["-O1"]-        MaximumOptimisation  ->  ["-O2"])+  -- verbosity+  ( if verbosity >= deafening+      then ["-v4"]+      else+        if verbosity >= normal+          then []+          else ["-v0"]+  )+    ++ hcOptions UHC bi+    -- flags for language extensions+    ++ languageToFlags (compiler lbi) (defaultLanguage bi)+    ++ extensionsToFlags (compiler lbi) (usedExtensions bi)+    -- packages+    ++ ["--hide-all-packages"]+    ++ uhcPackageDbOptions user system (withPackageDB lbi)+    ++ ["--package=uhcbase"]+    ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi]+    -- search paths+    ++ ["-i" ++ u odir]+    ++ ["-i" ++ u l | l <- nub (hsSourceDirs bi)]+    ++ ["-i" ++ u (autogenComponentModulesDir lbi clbi)]+    ++ ["-i" ++ u (autogenPackageModulesDir lbi)]+    -- cpp options+    ++ ["--optP=" ++ opt | opt <- cppOptions bi]+    -- output path+    ++ ["--odir=" ++ u odir]+    -- optimization+    ++ ( case withOptimization lbi of+          NoOptimisation -> ["-O0"]+          NormalOptimisation -> ["-O1"]+          MaximumOptimisation -> ["-O2"]+       )+  where+    u = interpretSymbolicPathCWD -- See Note [Symbolic paths] in Distribution.Utils.Path  uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String]-uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x)-                                         (concatMap (packageDbPaths user system) db)+uhcPackageDbOptions user system db =+  map+    (\x -> "--pkg-searchpath=" ++ x)+    (concatMap (packageDbPaths user system Nothing) db)  -- ----------------------------------------------------------------------------- -- Installation -installLib :: Verbosity -> LocalBuildInfo-           -> FilePath -> FilePath -> FilePath-           -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO ()+installLib+  :: Verbosity+  -> LocalBuildInfo+  -> FilePath+  -> FilePath+  -> FilePath+  -> PackageDescription+  -> Library+  -> ComponentLocalBuildInfo+  -> IO () installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do-    -- putStrLn $ "dest:  " ++ targetDir-    -- putStrLn $ "built: " ++ builtDir-    installDirectoryContents verbosity (builtDir </> prettyShow (packageId pkg)) targetDir+  -- putStrLn $ "dest:  " ++ targetDir+  -- putStrLn $ "built: " ++ builtDir+  installDirectoryContents verbosity (builtDir </> prettyShow (packageId pkg)) targetDir  -- currently hard-coded UHC code generator and variant to use uhcTarget, uhcTargetVariant :: String-uhcTarget        = "bc"+uhcTarget = "bc" uhcTargetVariant = "plain"  -- root directory for a package in UHC-uhcPackageDir    :: String -> String -> FilePath-uhcPackageSubDir ::           String -> FilePath-uhcPackageDir    pkgid compilerid = pkgid </> uhcPackageSubDir compilerid-uhcPackageSubDir       compilerid = compilerid </> uhcTarget </> uhcTargetVariant+uhcPackageDir :: String -> String -> FilePath+uhcPackageSubDir :: String -> FilePath+uhcPackageDir pkgid compilerid = pkgid </> uhcPackageSubDir compilerid+uhcPackageSubDir compilerid = compilerid </> uhcTarget </> uhcTargetVariant  -- ----------------------------------------------------------------------------- -- Registering  registerPackage   :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir from))   -> Compiler   -> ProgramDb-  -> PackageDBStack+  -> PackageDBStackS from   -> InstalledPackageInfo   -> IO ()-registerPackage verbosity comp progdb packageDbs installedPkgInfo = do-    dbdir <- case registrationPackageDB packageDbs of-      GlobalPackageDB       -> getGlobalPackageDir verbosity progdb-      UserPackageDB         -> getUserPackageDir-      SpecificPackageDB dir -> return dir-    let pkgdir = dbdir </> uhcPackageDir (prettyShow pkgid) (prettyShow compilerid)-    createDirectoryIfMissingVerbose verbosity True pkgdir-    writeUTF8File (pkgdir </> installedPkgConfig)-                  (showInstalledPackageInfo installedPkgInfo)+registerPackage verbosity mbWorkDir comp progdb packageDbs installedPkgInfo = do+  dbdir <- case registrationPackageDB packageDbs of+    GlobalPackageDB -> getGlobalPackageDir verbosity progdb+    UserPackageDB -> getUserPackageDir+    SpecificPackageDB dir -> return (interpretSymbolicPath mbWorkDir dir)+  let pkgdir = dbdir </> uhcPackageDir (prettyShow pkgid) (prettyShow compilerid)+  createDirectoryIfMissingVerbose verbosity True pkgdir+  writeUTF8File+    (pkgdir </> installedPkgConfig)+    (showInstalledPackageInfo installedPkgInfo)   where-    pkgid      = sourcePackageId installedPkgInfo+    pkgid = sourcePackageId installedPkgInfo     compilerid = compilerId comp -inplacePackageDbPath :: LocalBuildInfo -> FilePath-inplacePackageDbPath lbi = buildDir lbi+inplacePackageDbPath :: LocalBuildInfo -> SymbolicPath Pkg (Dir PkgDB)+inplacePackageDbPath lbi = coerceSymbolicPath $ buildDir lbi
src/Distribution/Simple/UserHooks.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Simple.UserHooks -- Copyright   :  Isaac Jones 2003-2005@@ -25,21 +26,21 @@ -- pass any extra parameters to most of the functions that implement the -- various phases because it would involve changing the types of the -- corresponding hook. At some point it will have to be replaced.--module Distribution.Simple.UserHooks (-        UserHooks(..), Args,-        emptyUserHooks,+module Distribution.Simple.UserHooks+  ( UserHooks (..)+  , Args+  , emptyUserHooks   ) where +import Distribution.Compat.Prelude hiding (getContents, putStr) import Prelude ()-import Distribution.Compat.Prelude  import Distribution.PackageDescription-import Distribution.Simple.Program import Distribution.Simple.Command+import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PreProcess+import Distribution.Simple.Program import Distribution.Simple.Setup-import Distribution.Simple.LocalBuildInfo  type Args = [String] @@ -49,149 +50,137 @@ -- * WARNING: The hooks interface is under rather constant flux as we try to -- understand users needs. Setup files that depend on this interface may -- break in future releases.-data UserHooks = UserHooks {--    -- | Read the description file-    readDesc :: IO (Maybe GenericPackageDescription),-    -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'.-    hookedPreProcessors :: [ PPSuffixHandler ],-    -- | These programs are detected at configure time.  Arguments for them are-    -- added to the configure command.-    hookedPrograms :: [Program],--    -- |Hook to run before configure command-    preConf  :: Args -> ConfigFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during configure.-    confHook :: (GenericPackageDescription, HookedBuildInfo)-            -> ConfigFlags -> IO LocalBuildInfo,-    -- |Hook to run after configure command-    postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before build command.  Second arg indicates verbosity level.-    preBuild  :: Args -> BuildFlags -> IO HookedBuildInfo,--    -- |Over-ride this hook to get different behavior during build.-    buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (),-    -- |Hook to run after build command.  Second arg indicates verbosity level.-    postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before repl command.  Second arg indicates verbosity level.-    preRepl  :: Args -> ReplFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during interpretation.-    replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO (),-    -- |Hook to run after repl command.  Second arg indicates verbosity level.-    postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before clean command.  Second arg indicates verbosity level.-    preClean  :: Args -> CleanFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during clean.-    cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (),-    -- |Hook to run after clean command.  Second arg indicates verbosity level.-    postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (),--    -- |Hook to run before copy command-    preCopy  :: Args -> CopyFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during copy.-    copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (),-    -- |Hook to run after copy command-    postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before install command-    preInst  :: Args -> InstallFlags -> IO HookedBuildInfo,--    -- |Over-ride this hook to get different behavior during install.-    instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (),-    -- |Hook to run after install command.  postInst should be run-    -- on the target, not on the build machine.-    postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before register command-    preReg  :: Args -> RegisterFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during registration.-    regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (),-    -- |Hook to run after register command-    postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before unregister command-    preUnreg  :: Args -> RegisterFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during unregistration.-    unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (),-    -- |Hook to run after unregister command-    postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before hscolour command.  Second arg indicates verbosity level.-    preHscolour  :: Args -> HscolourFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during hscolour.-    hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (),-    -- |Hook to run after hscolour command.  Second arg indicates verbosity level.-    postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before haddock command.  Second arg indicates verbosity level.-    preHaddock  :: Args -> HaddockFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during haddock.-    haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (),-    -- |Hook to run after haddock command.  Second arg indicates verbosity level.-    postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before test command.-    preTest :: Args -> TestFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during test.-    testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (),-    -- |Hook to run after test command.-    postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before bench command.-    preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during bench.-    benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO (),-    -- |Hook to run after bench command.-    postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO ()+data UserHooks = UserHooks+  { readDesc :: IO (Maybe GenericPackageDescription)+  -- ^ Read the description file+  , hookedPreProcessors :: [PPSuffixHandler]+  -- ^ Custom preprocessors in addition to and overriding 'knownSuffixHandlers'.+  , hookedPrograms :: [Program]+  -- ^ These programs are detected at configure time.  Arguments for them are+  -- added to the configure command.+  , preConf :: Args -> ConfigFlags -> IO HookedBuildInfo+  -- ^ Hook to run before configure command+  , confHook+      :: (GenericPackageDescription, HookedBuildInfo)+      -> ConfigFlags+      -> IO LocalBuildInfo+  -- ^ Over-ride this hook to get different behavior during configure.+  , postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()+  -- ^ Hook to run after configure command+  , preBuild :: Args -> BuildFlags -> IO HookedBuildInfo+  -- ^ Hook to run before build command.  Second arg indicates verbosity level.+  , buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()+  -- ^ Over-ride this hook to get different behavior during build.+  , postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()+  -- ^ Hook to run after build command.  Second arg indicates verbosity level.+  , preRepl :: Args -> ReplFlags -> IO HookedBuildInfo+  -- ^ Hook to run before repl command.  Second arg indicates verbosity level.+  , replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO ()+  -- ^ Over-ride this hook to get different behavior during interpretation.+  , postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO ()+  -- ^ Hook to run after repl command.  Second arg indicates verbosity level.+  , preClean :: Args -> CleanFlags -> IO HookedBuildInfo+  -- ^ Hook to run before clean command.  Second arg indicates verbosity level.+  , cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO ()+  -- ^ Over-ride this hook to get different behavior during clean.+  , postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO ()+  -- ^ Hook to run after clean command.  Second arg indicates verbosity level.+  , preCopy :: Args -> CopyFlags -> IO HookedBuildInfo+  -- ^ Hook to run before copy command+  , copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO ()+  -- ^ Over-ride this hook to get different behavior during copy.+  , postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO ()+  -- ^ Hook to run after copy command+  , preInst :: Args -> InstallFlags -> IO HookedBuildInfo+  -- ^ Hook to run before install command+  , instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()+  -- ^ Over-ride this hook to get different behavior during install.+  , postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO ()+  -- ^ Hook to run after install command.  postInst should be run+  --  on the target, not on the build machine.+  , preReg :: Args -> RegisterFlags -> IO HookedBuildInfo+  -- ^ Hook to run before register command+  , regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO ()+  -- ^ Over-ride this hook to get different behavior during registration.+  , postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO ()+  -- ^ Hook to run after register command+  , preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo+  -- ^ Hook to run before unregister command+  , unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO ()+  -- ^ Over-ride this hook to get different behavior during unregistration.+  , postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO ()+  -- ^ Hook to run after unregister command+  , preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo+  -- ^ Hook to run before hscolour command.  Second arg indicates verbosity level.+  , hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO ()+  -- ^ Over-ride this hook to get different behavior during hscolour.+  , postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO ()+  -- ^ Hook to run after hscolour command.  Second arg indicates verbosity level.+  , preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo+  -- ^ Hook to run before haddock command.  Second arg indicates verbosity level.+  , haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO ()+  -- ^ Over-ride this hook to get different behavior during haddock.+  , postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO ()+  -- ^ Hook to run after haddock command.  Second arg indicates verbosity level.+  , preTest :: Args -> TestFlags -> IO HookedBuildInfo+  -- ^ Hook to run before test command.+  , testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO ()+  -- ^ Over-ride this hook to get different behavior during test.+  , postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO ()+  -- ^ Hook to run after test command.+  , preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo+  -- ^ Hook to run before bench command.+  , benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO ()+  -- ^ Over-ride this hook to get different behavior during bench.+  , postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO ()+  -- ^ Hook to run after bench command.   } --- |Empty 'UserHooks' which do nothing.+-- | Empty 'UserHooks' which do nothing. emptyUserHooks :: UserHooks-emptyUserHooks-  = UserHooks {-      readDesc  = return Nothing,-      hookedPreProcessors = [],-      hookedPrograms      = [],-      preConf   = rn',-      confHook  = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")),-      postConf  = ru,-      preBuild  = rn',-      buildHook = ru,-      postBuild = ru,-      preRepl   = \_ _ -> return emptyHookedBuildInfo,-      replHook  = \_ _ _ _ _ -> return (),-      postRepl  = ru,-      preClean  = rn,-      cleanHook = ru,-      postClean = ru,-      preCopy   = rn',-      copyHook  = ru,-      postCopy  = ru,-      preInst   = rn,-      instHook  = ru,-      postInst  = ru,-      preReg    = rn',-      regHook   = ru,-      postReg   = ru,-      preUnreg  = rn,-      unregHook = ru,-      postUnreg = ru,-      preHscolour  = rn,-      hscolourHook = ru,-      postHscolour = ru,-      preHaddock   = rn',-      haddockHook  = ru,-      postHaddock  = ru,-      preTest  = rn',-      testHook = \_ -> ru,-      postTest = ru,-      preBench = rn',-      benchHook = \_ -> ru,-      postBench = ru+emptyUserHooks =+  UserHooks+    { readDesc = return Nothing+    , hookedPreProcessors = []+    , hookedPrograms = []+    , preConf = rn'+    , confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook."))+    , postConf = ru+    , preBuild = rn'+    , buildHook = ru+    , postBuild = ru+    , preRepl = \_ _ -> return emptyHookedBuildInfo+    , replHook = \_ _ _ _ _ -> return ()+    , postRepl = ru+    , preClean = rn+    , cleanHook = ru+    , postClean = ru+    , preCopy = rn'+    , copyHook = ru+    , postCopy = ru+    , preInst = rn+    , instHook = ru+    , postInst = ru+    , preReg = rn'+    , regHook = ru+    , postReg = ru+    , preUnreg = rn+    , unregHook = ru+    , postUnreg = ru+    , preHscolour = rn+    , hscolourHook = ru+    , postHscolour = ru+    , preHaddock = rn'+    , haddockHook = ru+    , postHaddock = ru+    , preTest = rn'+    , testHook = \_ -> ru+    , postTest = ru+    , preBench = rn'+    , benchHook = \_ -> ru+    , postBench = ru     }-    where rn  args _ = noExtraFlags args >> return emptyHookedBuildInfo-          rn' _    _ = return emptyHookedBuildInfo-          ru _ _ _ _ = return ()+  where+    rn args _ = noExtraFlags args >> return emptyHookedBuildInfo+    rn' _ _ = return emptyHookedBuildInfo+    ru _ _ _ _ = return ()
src/Distribution/Simple/Utils.hs view
@@ -1,1609 +1,2072 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE BangPatterns #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Utils--- Copyright   :  Isaac Jones, Simon Marlow 2003-2004--- License     :  BSD3---                portions Copyright (c) 2007, Galois Inc.------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ A large and somewhat miscellaneous collection of utility functions used--- throughout the rest of the Cabal lib and in other tools that use the Cabal--- lib like @cabal-install@. It has a very simple set of logging actions. It--- has low level functions for running programs, a bunch of wrappers for--- various directory and file functions that do extra logging.--module Distribution.Simple.Utils (-        cabalVersion,--        -- * logging and errors-        dieNoVerbosity,-        die', dieWithLocation',-        dieNoWrap,-        topHandler, topHandlerWith,-        warn,-        notice, noticeNoWrap, noticeDoc,-        setupMessage,-        info, infoNoWrap,-        debug, debugNoWrap,-        chattyTry,-        annotateIO,-        printRawCommandAndArgs, printRawCommandAndArgsAndEnv,-        withOutputMarker,--        -- * exceptions-        handleDoesNotExist,--        -- * running programs-        rawSystemExit,-        rawSystemExitCode,-        rawSystemExitWithEnv,-        rawSystemStdout,-        rawSystemStdInOut,-        rawSystemIOWithEnv,-        rawSystemIOWithEnvAndAction,-        createProcessWithEnv,-        maybeExit,-        xargs,-        findProgramVersion,--        -- ** 'IOData' re-export-        ---        -- These types are re-exported from-        -- "Distribution.Utils.IOData" for convience as they're-        -- exposed in the API of 'rawSystemStdInOut'-        IOData(..),-        KnownIODataMode (..),-        IODataMode (..),--        -- * copying files-        createDirectoryIfMissingVerbose,-        copyFileVerbose,-        copyFiles,-        copyFileTo,--        -- * installing files-        installOrdinaryFile,-        installExecutableFile,-        installMaybeExecutableFile,-        installOrdinaryFiles,-        installExecutableFiles,-        installMaybeExecutableFiles,-        installDirectoryContents,-        copyDirectoryRecursive,--        -- * File permissions-        doesExecutableExist,-        setFileOrdinary,-        setFileExecutable,--        -- * file names-        currentDir,-        shortRelativePath,-        dropExeExtension,-        exeExtensions,--        -- * finding files-        findFileEx,-        findFileCwd,-        findFirstFile,-        findFileWithExtension,-        findFileCwdWithExtension,-        findFileWithExtension',-        findAllFilesWithExtension,-        findAllFilesCwdWithExtension,-        findModuleFileEx,-        findModuleFilesEx,-        getDirectoryContentsRecursive,--        -- * environment variables-        isInSearchPath,-        addLibraryPath,--        -- * modification time-        moreRecentFile,-        existsAndIsMoreRecentThan,--        -- * temp files and dirs-        TempFileOptions(..), defaultTempFileOptions,-        withTempFile, withTempFileEx,-        withTempDirectory, withTempDirectoryEx,-        createTempDirectory,--        -- * .cabal and .buildinfo files-        defaultPackageDesc,-        findPackageDesc,-        findPackageDescCwd,-        tryFindPackageDesc,-        tryFindPackageDescCwd,-        findHookedPackageDesc,--        -- * reading and writing files safely-        withFileContents,-        writeFileAtomic,-        rewriteFileEx,-        rewriteFileLBS,--        -- * Unicode-        fromUTF8BS,-        fromUTF8LBS,-        toUTF8BS,-        toUTF8LBS,-        readUTF8File,-        withUTF8FileContents,-        writeUTF8File,-        normaliseLineEndings,--        -- * BOM-        ignoreBOM,--        -- * generic utils-        dropWhileEndLE,-        takeWhileEndLE,-        equating,-        comparing,-        isInfixOf,-        intercalate,-        lowercase,-        listUnion,-        listUnionRight,-        ordNub,-        ordNubBy,-        ordNubRight,-        safeHead,-        safeTail,-        safeLast,-        safeInit,-        unintersperse,-        wrapText,-        wrapLine,--        -- * FilePath stuff-        isAbsoluteOnAnyPlatform,-        isRelativeOnAnyPlatform,--        -- * Deprecated functions-        findFile,-        findModuleFile,-        findModuleFiles,-  ) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Utils.Generic-import Distribution.Utils.IOData (IOData(..), IODataMode (..), KnownIODataMode (..))-import qualified Distribution.Utils.IOData as IOData-import Distribution.ModuleName as ModuleName-import Distribution.System-import Distribution.Version-import Distribution.Compat.Async-import Distribution.Compat.CopyFile-import Distribution.Compat.Internal.TempFile-import Distribution.Compat.FilePath as FilePath-import Distribution.Compat.Stack-import Distribution.Verbosity-import Distribution.Types.PackageId--#if __GLASGOW_HASKELL__ < 711-#ifdef VERSION_base-#define BOOTSTRAPPED_CABAL 1-#endif-#else-#ifdef CURRENT_PACKAGE_KEY-#define BOOTSTRAPPED_CABAL 1-#endif-#endif--#ifdef BOOTSTRAPPED_CABAL-import qualified Paths_Cabal (version)-#endif--import Distribution.Pretty-import Distribution.Parsec--import Data.Typeable-    ( cast )-import qualified Data.ByteString.Lazy as BS--import System.Directory-    ( Permissions(executable), getDirectoryContents, getPermissions-    , doesDirectoryExist, doesFileExist, removeFile-    , getModificationTime, createDirectory, removeDirectoryRecursive )-import System.Environment-    ( getProgName )-import System.FilePath as FilePath-    ( normalise, (</>), (<.>)-    , getSearchPath, joinPath, takeDirectory, splitExtension-    , splitDirectories, searchPathSeparator )-import System.IO-    ( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush-    , hClose, hSetBuffering, BufferMode(..), hPutStrLn )-import System.IO.Error-import System.IO.Unsafe-    ( unsafeInterleaveIO )-import qualified Control.Exception as Exception--import Foreign.C.Error (Errno (..), ePIPE)-import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime)-import Numeric (showFFloat)-import Distribution.Compat.Process  (createProcess, rawSystem, runInteractiveProcess)-import System.Process-         ( ProcessHandle-         , showCommandForUser, waitForProcess)-import qualified System.Process as Process-import qualified GHC.IO.Exception as GHC--import qualified Text.PrettyPrint as Disp---- We only get our own version number when we're building with ourselves-cabalVersion :: Version-#if defined(BOOTSTRAPPED_CABAL)-cabalVersion = mkVersion' Paths_Cabal.version-#elif defined(CABAL_VERSION)-cabalVersion = mkVersion [CABAL_VERSION]-#else-cabalVersion = mkVersion [3,0]  --used when bootstrapping-#endif---- ------------------------------------------------------------------------------- Exception and logging utils---- Cabal's logging infrastructure has a few constraints:------  * We must make all logging formatting and emissions decisions based---    on the 'Verbosity' parameter, which is the only parameter that is---    plumbed to enough call-sites to actually be used for this matter.---    (One of Cabal's "big mistakes" is to have never have defined a---    monad of its own.)------  * When we 'die', we must raise an IOError.  This a backwards---    compatibility consideration, because that's what we've raised---    previously, and if we change to any other exception type,---    exception handlers which match on IOError will no longer work.---    One case where it is known we rely on IOError being catchable---    is 'readPkgConfigDb' in cabal-install; there may be other---    user code that also assumes this.------  * The 'topHandler' does not know what 'Verbosity' is, because---    it gets called before we've done command line parsing (where---    the 'Verbosity' parameter would come from).------ This leads to two big architectural choices:------  * Although naively we might imagine 'Verbosity' to be a simple---    enumeration type, actually it is a full-on abstract data type---    that may contain arbitrarily complex information.  At the---    moment, it is fully representable as a string, but we might---    eventually also use verbosity to let users register their---    own logging handler.------  * When we call 'die', we perform all the formatting and addition---    of extra information we need, and then ship this in the IOError---    to the top-level handler.  Here are alternate designs that---    don't work:------      a) Ship the unformatted info to the handler.  This doesn't---      work because at the point the handler gets the message,---      we've lost call stacks, and even if we did, we don't have access---      to 'Verbosity' to decide whether or not to render it.------      b) Print the information at the 'die' site, then raise an---      error.  This means that if the exception is subsequently---      caught by a handler, we will still have emitted the output,---      which is not the correct behavior.------    For the top-level handler to "know" that an error message---    contains one of these fully formatted packets, we set a sentinel---    in one of IOError's extra fields.  This is handled by---    'ioeSetVerbatim' and 'ioeGetVerbatim'.-----dieNoVerbosity :: String -> IO a-dieNoVerbosity msg-    = ioError (userError msg)-  where-    _ = callStack -- TODO: Attach CallStack to exception---- | Tag an 'IOError' whose error string should be output to the screen--- verbatim.-ioeSetVerbatim :: IOError -> IOError-ioeSetVerbatim e = ioeSetLocation e "dieVerbatim"---- | Check if an 'IOError' should be output verbatim to screen.-ioeGetVerbatim :: IOError -> Bool-ioeGetVerbatim e = ioeGetLocation e == "dieVerbatim"---- | Create a 'userError' whose error text will be output verbatim-verbatimUserError :: String -> IOError-verbatimUserError = ioeSetVerbatim . userError--dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a-dieWithLocation' verbosity filename mb_lineno msg = withFrozenCallStack $ do-    ts <- getPOSIXTime-    pname <- getProgName-    ioError . verbatimUserError-            . withMetadata ts AlwaysMark VerboseTrace verbosity-            . wrapTextVerbosity verbosity-            $ pname ++ ": " ++-              filename ++ (case mb_lineno of-                            Just lineno -> ":" ++ show lineno-                            Nothing -> "") ++-              ": " ++ msg--die' :: Verbosity -> String -> IO a-die' verbosity msg = withFrozenCallStack $ do-    ts <- getPOSIXTime-    pname <- getProgName-    ioError . verbatimUserError-            . withMetadata ts AlwaysMark VerboseTrace verbosity-            . wrapTextVerbosity verbosity-            $ pname ++ ": " ++ msg--dieNoWrap :: Verbosity -> String -> IO a-dieNoWrap verbosity msg = withFrozenCallStack $ do-    -- TODO: should this have program name or not?-    ts <- getPOSIXTime-    ioError . verbatimUserError-            . withMetadata ts AlwaysMark VerboseTrace verbosity-            $ msg---- | Given a block of IO code that may raise an exception, annotate--- it with the metadata from the current scope.  Use this as close--- to external code that raises IO exceptions as possible, since--- this function unconditionally wraps the error message with a trace--- (so it is NOT idempotent.)-annotateIO :: Verbosity -> IO a -> IO a-annotateIO verbosity act = do-    ts <- getPOSIXTime-    modifyIOError (f ts) act-  where-    f ts ioe = ioeSetErrorString ioe-             . withMetadata ts NeverMark VerboseTrace verbosity-             $ ioeGetErrorString ioe---{-# NOINLINE topHandlerWith #-}-topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a-topHandlerWith cont prog = do-    -- By default, stderr to a terminal device is NoBuffering. But this-    -- is *really slow*-    hSetBuffering stderr LineBuffering-    Exception.catches prog [-        Exception.Handler rethrowAsyncExceptions-      , Exception.Handler rethrowExitStatus-      , Exception.Handler handle-      ]-  where-    -- Let async exceptions rise to the top for the default top-handler-    rethrowAsyncExceptions :: Exception.AsyncException -> IO a-    rethrowAsyncExceptions a = throwIO a--    -- ExitCode gets thrown asynchronously too, and we don't want to print it-    rethrowExitStatus :: ExitCode -> IO a-    rethrowExitStatus = throwIO--    -- Print all other exceptions-    handle :: Exception.SomeException -> IO a-    handle se = do-      hFlush stdout-      pname <- getProgName-      hPutStr stderr (message pname se)-      cont se--    message :: String -> Exception.SomeException -> String-    message pname (Exception.SomeException se) =-      case cast se :: Maybe Exception.IOException of-        Just ioe-         | ioeGetVerbatim ioe ->-            -- Use the message verbatim-            ioeGetErrorString ioe ++ "\n"-         | isUserError ioe ->-          let file         = case ioeGetFileName ioe of-                               Nothing   -> ""-                               Just path -> path ++ location ++ ": "-              location     = case ioeGetLocation ioe of-                               l@(n:_) | isDigit n -> ':' : l-                               _                        -> ""-              detail       = ioeGetErrorString ioe-          in wrapText (pname ++ ": " ++ file ++ detail)-        _ ->-          displaySomeException se ++ "\n"---- | BC wrapper around 'Exception.displayException'.-displaySomeException :: Exception.Exception e => e -> String-displaySomeException se =-#if __GLASGOW_HASKELL__ < 710-    show se-#else-    Exception.displayException se-#endif--topHandler :: IO a -> IO a-topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog--verbosityHandle :: Verbosity -> Handle-verbosityHandle verbosity-    | isVerboseStderr verbosity = stderr-    | otherwise                 = stdout---- | Non fatal conditions that may be indicative of an error or problem.------ We display these at the 'normal' verbosity level.----warn :: Verbosity -> String -> IO ()-warn verbosity msg = withFrozenCallStack $ do-  when (verbosity >= normal) $ do-    ts <- getPOSIXTime-    hFlush stdout-    hPutStr stderr . withMetadata ts NormalMark FlagTrace verbosity-                   . wrapTextVerbosity verbosity-                   $ "Warning: " ++ msg---- | Useful status messages.------ We display these at the 'normal' verbosity level.------ This is for the ordinary helpful status messages that users see. Just--- enough information to know that things are working but not floods of detail.----notice :: Verbosity -> String -> IO ()-notice verbosity msg = withFrozenCallStack $ do-  when (verbosity >= normal) $ do-    let h = verbosityHandle verbosity-    ts <- getPOSIXTime-    hPutStr h-        $ withMetadata ts NormalMark FlagTrace verbosity-        $ wrapTextVerbosity verbosity-        $ msg---- | 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-    ts <- getPOSIXTime-    hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ 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-    ts <- getPOSIXTime-    hPutStr h-        $ withMetadata ts NormalMark FlagTrace verbosity-        $ Disp.renderStyle defaultStyle-        $ msg---- | Display a "setup status message".  Prefer using setupMessage'--- if possible.----setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()-setupMessage verbosity msg pkgid = withFrozenCallStack $ do-    noticeNoWrap verbosity (msg ++ ' ': prettyShow pkgid ++ "...")---- | More detail on the operation of some action.------ We display these messages when the verbosity level is 'verbose'----info :: Verbosity -> String -> IO ()-info verbosity msg = withFrozenCallStack $-  when (verbosity >= verbose) $ do-    let h = verbosityHandle verbosity-    ts <- getPOSIXTime-    hPutStr h-        $ withMetadata ts NeverMark FlagTrace verbosity-        $ wrapTextVerbosity verbosity-        $ msg--infoNoWrap :: Verbosity -> String -> IO ()-infoNoWrap verbosity msg = withFrozenCallStack $-  when (verbosity >= verbose) $ do-    let h = verbosityHandle verbosity-    ts <- getPOSIXTime-    hPutStr h-        $ withMetadata ts NeverMark FlagTrace verbosity-        $ msg---- | Detailed internal debugging information------ We display these messages when the verbosity level is 'deafening'----debug :: Verbosity -> String -> IO ()-debug verbosity msg = withFrozenCallStack $-  when (verbosity >= deafening) $ do-    let h = verbosityHandle verbosity-    ts <- getPOSIXTime-    hPutStr h $ withMetadata ts NeverMark FlagTrace verbosity-              $ wrapTextVerbosity verbosity-              $ msg-    -- ensure that we don't lose output if we segfault/infinite loop-    hFlush stdout---- | A variant of 'debug' that doesn't perform the automatic line--- wrapping. Produces better output in some cases.-debugNoWrap :: Verbosity -> String -> IO ()-debugNoWrap verbosity msg = withFrozenCallStack $-  when (verbosity >= deafening) $ do-    let h = verbosityHandle verbosity-    ts <- getPOSIXTime-    hPutStr h-        $ withMetadata ts NeverMark FlagTrace verbosity-        $ msg-    -- ensure that we don't lose output if we segfault/infinite loop-    hFlush stdout---- | Perform an IO action, catching any IO exceptions and printing an error---   if one occurs.-chattyTry :: String  -- ^ a description of the action we were attempting-          -> IO ()   -- ^ the action itself-          -> IO ()-chattyTry desc action =-  catchIO action $ \exception ->-    hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception---- | Run an IO computation, returning @e@ if it raises a "file--- does not exist" error.-handleDoesNotExist :: a -> IO a -> IO a-handleDoesNotExist e =-    Exception.handleJust-      (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing)-      (\_ -> return e)---- -------------------------------------------------------------------------------- Helper functions---- | Wraps text unless the @+nowrap@ verbosity flag is active-wrapTextVerbosity :: Verbosity -> String -> String-wrapTextVerbosity verb-  | isVerboseNoWrap verb = withTrailingNewline-  | otherwise            = withTrailingNewline . wrapText----- | Prepends a timestamp if @+timestamp@ verbosity flag is set------ This is used by 'withMetadata'----withTimestamp :: Verbosity -> POSIXTime -> String -> String-withTimestamp v ts msg-  | isVerboseTimestamp v  = msg'-  | otherwise             = msg -- no-op-  where-    msg' = case lines msg of-      []      -> tsstr "\n"-      l1:rest -> unlines (tsstr (' ':l1) : map (contpfx++) rest)--    -- format timestamp to be prepended to first line with msec precision-    tsstr = showFFloat (Just 3) (realToFrac ts :: Double)--    -- continuation prefix for subsequent lines of msg-    contpfx = replicate (length (tsstr " ")) ' '---- | Wrap output with a marker if @+markoutput@ verbosity flag is set.------ NB: Why is markoutput done with start/end markers, and not prefixes?--- Markers are more convenient to add (if we want to add prefixes,--- we have to 'lines' and then 'map'; here's it's just some--- concatenates).  Note that even in the prefix case, we can't--- guarantee that the markers are unambiguous, because some of--- Cabal's output comes straight from external programs, where--- we don't have the ability to interpose on the output.------ This is used by 'withMetadata'----withOutputMarker :: Verbosity -> String -> String-withOutputMarker v xs | not (isVerboseMarkOutput v) = xs-withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly-withOutputMarker _ xs =-    "-----BEGIN CABAL OUTPUT-----\n" ++-    withTrailingNewline xs ++-    "-----END CABAL OUTPUT-----\n"---- | Append a trailing newline to a string if it does not--- already have a trailing newline.----withTrailingNewline :: String -> String-withTrailingNewline "" = ""-withTrailingNewline (x:xs) = x : go x xs-  where-    go   _ (c:cs) = c : go c cs-    go '\n' "" = ""-    go   _  "" = "\n"---- | Prepend a call-site and/or call-stack based on Verbosity----withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String)-withCallStackPrefix tracer verbosity s = withFrozenCallStack $-    (if isVerboseCallSite verbosity-        then parentSrcLocPrefix ++-             -- Hack: need a newline before starting output marker :(-             if isVerboseMarkOutput verbosity-                then "\n"-                else ""-        else "") ++-    (case traceWhen verbosity tracer of-        Just pre -> pre ++ prettyCallStack callStack ++ "\n"-        Nothing  -> "") ++-    s---- | When should we emit the call stack?  We always emit--- for internal errors, emit the trace for errors when we--- are in verbose mode, and otherwise only emit it if--- explicitly asked for using the @+callstack@ verbosity--- flag.  (At the moment, 'AlwaysTrace' is not used.----data TraceWhen-    = AlwaysTrace-    | VerboseTrace-    | FlagTrace-    deriving (Eq)---- | Determine if we should emit a call stack.--- If we trace, it also emits any prefix we should append.-traceWhen :: Verbosity -> TraceWhen -> Maybe String-traceWhen _ AlwaysTrace = Just ""-traceWhen v VerboseTrace | v >= verbose         = Just ""-traceWhen v FlagTrace    | isVerboseCallStack v = Just "----\n"-traceWhen _ _ = Nothing---- | When should we output the marker?  Things like 'die'--- always get marked, but a 'NormalMark' will only be--- output if we're not a quiet verbosity.----data MarkWhen = AlwaysMark | NormalMark | NeverMark---- | Add all necessary metadata to a logging message----withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)-withMetadata ts marker tracer verbosity x = withFrozenCallStack $-    -- NB: order matters.  Output marker first because we-    -- don't want to capture call stacks.-      withTrailingNewline-    . withCallStackPrefix tracer verbosity-    . (case marker of-        AlwaysMark -> withOutputMarker verbosity-        NormalMark | not (isVerboseQuiet verbosity)-                   -> withOutputMarker verbosity-                   | otherwise-                   -> id-        NeverMark  -> id)-    -- Clear out any existing markers-    . clearMarkers-    . withTimestamp verbosity ts-    $ x--clearMarkers :: String -> String-clearMarkers s = unlines . filter isMarker $ lines s-  where-    isMarker "-----BEGIN CABAL OUTPUT-----" = False-    isMarker "-----END CABAL OUTPUT-----"   = False-    isMarker _ = True---- -------------------------------------------------------------------------------- rawSystem variants-maybeExit :: IO ExitCode -> IO ()-maybeExit cmd = do-  res <- cmd-  unless (res == ExitSuccess) $ exitWith res----printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()-printRawCommandAndArgs verbosity path args = withFrozenCallStack $-    printRawCommandAndArgsAndEnv verbosity path args Nothing Nothing--printRawCommandAndArgsAndEnv :: Verbosity-                             -> FilePath-                             -> [String]-                             -> Maybe FilePath-                             -> Maybe [(String, String)]-                             -> IO ()-printRawCommandAndArgsAndEnv verbosity path args mcwd menv = do-    case menv of-        Just env -> debugNoWrap verbosity ("Environment: " ++ show env)-        Nothing -> return ()-    case mcwd of-        Just cwd -> debugNoWrap verbosity ("Working directory: " ++ show cwd)-        Nothing -> return ()-    infoNoWrap verbosity (showCommandForUser path args)---- Exit with the same exit code if the subcommand fails-rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()-rawSystemExit verbosity path args = withFrozenCallStack $ do-  printRawCommandAndArgs verbosity path args-  hFlush stdout-  exitcode <- rawSystem path args-  unless (exitcode == ExitSuccess) $ do-    debug verbosity $ path ++ " returned " ++ show exitcode-    exitWith exitcode--rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode-rawSystemExitCode verbosity path args = withFrozenCallStack $ do-  printRawCommandAndArgs verbosity path args-  hFlush stdout-  exitcode <- rawSystem path args-  unless (exitcode == ExitSuccess) $ do-    debug verbosity $ path ++ " returned " ++ show exitcode-  return exitcode--rawSystemExitWithEnv :: Verbosity-                     -> FilePath-                     -> [String]-                     -> [(String, String)]-                     -> IO ()-rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ do-    printRawCommandAndArgsAndEnv verbosity path args Nothing (Just env)-    hFlush stdout-    (_,_,_,ph) <- createProcess $-                  (Process.proc path args) { Process.env = (Just env)-#ifdef MIN_VERSION_process-#if MIN_VERSION_process(1,2,0)--- delegate_ctlc has been added in process 1.2, and we still want to be able to--- bootstrap GHC on systems not having that version-                                           , Process.delegate_ctlc = True-#endif-#endif-                                           }-    exitcode <- waitForProcess ph-    unless (exitcode == ExitSuccess) $ do-        debug verbosity $ path ++ " returned " ++ show exitcode-        exitWith exitcode---- Closes the passed in handles before returning.-rawSystemIOWithEnv :: Verbosity-                   -> FilePath-                   -> [String]-                   -> Maybe FilePath           -- ^ New working dir or inherit-                   -> Maybe [(String, String)] -- ^ New environment or inherit-                   -> Maybe Handle  -- ^ stdin-                   -> Maybe Handle  -- ^ stdout-                   -> Maybe Handle  -- ^ stderr-                   -> IO ExitCode-rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do-    (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv-                                       (mbToStd inp) (mbToStd out) (mbToStd err)-    exitcode <- waitForProcess ph-    unless (exitcode == ExitSuccess) $ do-      debug verbosity $ path ++ " returned " ++ show exitcode-    return exitcode-  where-    mbToStd :: Maybe Handle -> Process.StdStream-    mbToStd = maybe Process.Inherit Process.UseHandle--rawSystemIOWithEnvAndAction-    :: Verbosity-    -> FilePath-    -> [String]-    -> Maybe FilePath           -- ^ New working dir or inherit-    -> Maybe [(String, String)] -- ^ New environment or inherit-    -> IO a          -- ^ action to perform after process is created, but before 'waitForProcess'.-    -> Maybe Handle  -- ^ stdin-    -> Maybe Handle  -- ^ stdout-    -> Maybe Handle  -- ^ stderr-    -> IO (ExitCode, a)-rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do-    (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv-                                       (mbToStd inp) (mbToStd out) (mbToStd err)-    a <- action-    exitcode <- waitForProcess ph-    unless (exitcode == ExitSuccess) $ do-      debug verbosity $ path ++ " returned " ++ show exitcode-    return (exitcode, a)-  where-    mbToStd :: Maybe Handle -> Process.StdStream-    mbToStd = maybe Process.Inherit Process.UseHandle--createProcessWithEnv ::-     Verbosity-  -> FilePath-  -> [String]-  -> Maybe FilePath           -- ^ New working dir or inherit-  -> Maybe [(String, String)] -- ^ New environment or inherit-  -> Process.StdStream  -- ^ stdin-  -> Process.StdStream  -- ^ stdout-  -> Process.StdStream  -- ^ stderr-  -> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle)-  -- ^ Any handles created for stdin, stdout, or stderr-  -- with 'CreateProcess', and a handle to the process.-createProcessWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do-    printRawCommandAndArgsAndEnv verbosity path args mcwd menv-    hFlush stdout-    (inp', out', err', ph) <- createProcess $-                                (Process.proc path args) {-                                    Process.cwd           = mcwd-                                  , Process.env           = menv-                                  , Process.std_in        = inp-                                  , Process.std_out       = out-                                  , Process.std_err       = err-#ifdef MIN_VERSION_process-#if MIN_VERSION_process(1,2,0)--- delegate_ctlc has been added in process 1.2, and we still want to be able to--- bootstrap GHC on systems not having that version-                                  , Process.delegate_ctlc = True-#endif-#endif-                                  }-    return (inp', out', err', ph)---- | Run a command and return its output.------ The output is assumed to be text in the locale encoding.----rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode-rawSystemStdout verbosity path args = withFrozenCallStack $ do-  (output, errors, exitCode) <- rawSystemStdInOut verbosity path args-    Nothing Nothing Nothing (IOData.iodataMode :: IODataMode mode)-  when (exitCode /= ExitSuccess) $-    die' verbosity errors-  return output---- | Run a command and return its output, errors and exit status. Optionally--- also supply some input. Also provides control over whether the binary/text--- mode of the input and output.----rawSystemStdInOut :: KnownIODataMode mode-                  => Verbosity-                  -> FilePath                 -- ^ Program location-                  -> [String]                 -- ^ Arguments-                  -> Maybe FilePath           -- ^ New working dir or inherit-                  -> Maybe [(String, String)] -- ^ New environment or inherit-                  -> Maybe IOData             -- ^ input text and binary mode-                  -> IODataMode mode          -- ^ iodata mode, acts as proxy-                  -> IO (mode, String, ExitCode) -- ^ output, errors, exit-rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do-  printRawCommandAndArgs verbosity path args--  Exception.bracket-     (runInteractiveProcess path args mcwd menv)-     (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)-    $ \(inh,outh,errh,pid) -> do--      -- output mode depends on what the caller wants-      -- but the errors are always assumed to be text (in the current locale)-      hSetBinaryMode errh False--      -- fork off a couple threads to pull on the stderr and stdout-      -- so if the process writes to stderr we do not block.--      withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do-        -- push all the input, if any-        ignoreSigPipe $ case input of-          Nothing        -> hClose inh-          Just inputData -> IOData.hPutContents inh inputData--        -- wait for both to finish-        mberr1 <- waitCatch outA-        mberr2 <- waitCatch errA--        -- wait for the program to terminate-        exitcode <- waitForProcess pid--        -- get the stderr, so it can be added to error message-        err <- reportOutputIOError mberr2--        unless (exitcode == ExitSuccess) $-          debug verbosity $ path ++ " returned " ++ show exitcode-                         ++ if null err then "" else-                            " with error message:\n" ++ err-                         ++ case input of-                              Nothing       -> ""-                              Just d | IOData.null d  -> ""-                              Just (IODataText inp)   -> "\nstdin input:\n" ++ inp-                              Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp--        -- Check if we hit an exception while consuming the output-        -- (e.g. a text decoding error)-        out <- reportOutputIOError mberr1--        return (out, err, exitcode)-  where-    reportOutputIOError :: Either Exception.SomeException a -> IO a-    reportOutputIOError (Right x) = return x-    reportOutputIOError (Left exc) = case fromException exc of-        Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path))-        Nothing  -> throwIO exc--    ignoreSigPipe :: IO () -> IO ()-    ignoreSigPipe = Exception.handle $ \e -> case e of-        GHC.IOError { GHC.ioe_type  = GHC.ResourceVanished, GHC.ioe_errno = Just ioe }-            | Errno ioe == ePIPE -> return ()-        _ -> throwIO e---- | Look for a program and try to find it's version number. It can accept--- either an absolute path or the name of a program binary, in which case we--- will look for the program on the path.----findProgramVersion :: String             -- ^ version args-                   -> (String -> String) -- ^ function to select version-                                         --   number from program output-                   -> Verbosity-                   -> FilePath           -- ^ location-                   -> IO (Maybe Version)-findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do-  str <- rawSystemStdout verbosity path [versionArg]-         `catchIO`   (\_ -> return "")-         `catchExit` (\_ -> return "")-  let version :: Maybe Version-      version = simpleParsec (selectVersion str)-  case version of-      Nothing -> warn verbosity $ "cannot determine version of " ++ path-                               ++ " :\n" ++ show str-      Just v  -> debug verbosity $ path ++ " is version " ++ prettyShow v-  return version----- | Like the Unix xargs program. Useful for when we've got very long command--- lines that might overflow an OS limit on command line length and so you--- need to invoke a command multiple times to get all the args in.------ Use it with either of the rawSystem variants above. For example:------ > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs----xargs :: Int -> ([String] -> IO ())-      -> [String] -> [String] -> IO ()-xargs maxSize rawSystemFun fixedArgs bigArgs =-  let fixedArgSize = sum (map length fixedArgs) + length fixedArgs-      chunkSize = maxSize - fixedArgSize-   in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)--  where chunks len = unfoldr $ \s ->-          if null s then Nothing-                    else Just (chunk [] len s)--        chunk acc _   []     = (reverse acc,[])-        chunk acc len (s:ss)-          | len' < len = chunk (s:acc) (len-len'-1) ss-          | otherwise  = (reverse acc, s:ss)-          where len' = length s---- --------------------------------------------------------------- * File Utilities--- --------------------------------------------------------------------------------- Finding files---{-# DEPRECATED findFile "Use findFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-}-findFile :: [FilePath]    -- ^search locations-         -> FilePath      -- ^File Name-         -> IO FilePath-findFile = findFileEx normal---- | Find a file by looking in a search path. The file path must match exactly.------ @since 3.4.0.0-findFileCwd-    :: Verbosity-    -> FilePath      -- ^ cwd-    -> [FilePath]    -- ^ relative search location-    -> FilePath      -- ^ File Name-    -> IO FilePath-findFileCwd verbosity cwd searchPath fileName =-  findFirstFile (cwd </>)-    [ path </> fileName-    | path <- nub searchPath]-  >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return---- | Find a file by looking in a search path. The file path must match exactly.----findFileEx :: Verbosity-           -> [FilePath]    -- ^search locations-           -> FilePath      -- ^File Name-           -> IO FilePath-findFileEx verbosity searchPath fileName =-  findFirstFile id-    [ path </> fileName-    | path <- nub searchPath]-  >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return---- | Find a file by looking in a search path with one of a list of possible--- file extensions. The file base name should be given and it will be tried--- with each of the extensions in each element of the search path.----findFileWithExtension :: [String]-                      -> [FilePath]-                      -> FilePath-                      -> IO (Maybe FilePath)-findFileWithExtension extensions searchPath baseName =-  findFirstFile id-    [ path </> baseName <.> ext-    | path <- nub searchPath-    , ext <- nub extensions ]---- | @since 3.4.0.0-findFileCwdWithExtension-    :: FilePath-    -> [String]-    -> [FilePath]-    -> FilePath-    -> IO (Maybe FilePath)-findFileCwdWithExtension cwd extensions searchPath baseName =-  findFirstFile (cwd </>)-    [ path </> baseName <.> ext-    | path <- nub searchPath-    , ext <- nub extensions ]---- | @since 3.4.0.0-findAllFilesCwdWithExtension-    :: FilePath       -- ^ cwd-    -> [String]       -- ^ extensions-    -> [FilePath]     -- ^ relative search locations-    -> FilePath       -- ^ basename-    -> IO [FilePath]-findAllFilesCwdWithExtension cwd extensions searchPath basename =-  findAllFiles (cwd </>)-    [ path </> basename <.> ext-    | path <- nub searchPath-    , ext <- nub extensions ]--findAllFilesWithExtension :: [String]-                          -> [FilePath]-                          -> FilePath-                          -> IO [FilePath]-findAllFilesWithExtension extensions searchPath basename =-  findAllFiles id-    [ path </> basename <.> ext-    | path <- nub searchPath-    , ext <- nub extensions ]---- | Like 'findFileWithExtension' but returns which element of the search path--- the file was found in, and the file path relative to that base directory.----findFileWithExtension' :: [String]-                       -> [FilePath]-                       -> FilePath-                       -> IO (Maybe (FilePath, FilePath))-findFileWithExtension' extensions searchPath baseName =-  findFirstFile (uncurry (</>))-    [ (path, baseName <.> ext)-    | path <- nub searchPath-    , ext <- nub extensions ]--findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a)-findFirstFile file = findFirst-  where findFirst []     = return Nothing-        findFirst (x:xs) = do exists <- doesFileExist (file x)-                              if exists-                                then return (Just x)-                                else findFirst xs--findAllFiles :: (a -> FilePath) -> [a] -> IO [a]-findAllFiles file = filterM (doesFileExist . file)---{-# DEPRECATED findModuleFiles "Use findModuleFilesEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-}-findModuleFiles :: [FilePath]   -- ^ build prefix (location of objects)-                -> [String]     -- ^ search suffixes-                -> [ModuleName] -- ^ modules-                -> IO [(FilePath, FilePath)]-findModuleFiles = findModuleFilesEx normal---- | Finds the files corresponding to a list of Haskell module names.------ As 'findModuleFile' but for a list of module names.----findModuleFilesEx :: Verbosity-                  -> [FilePath]   -- ^ build prefix (location of objects)-                  -> [String]     -- ^ search suffixes-                  -> [ModuleName] -- ^ modules-                  -> IO [(FilePath, FilePath)]-findModuleFilesEx verbosity searchPath extensions moduleNames =-  traverse (findModuleFileEx verbosity searchPath extensions) moduleNames--{-# DEPRECATED findModuleFile "Use findModuleFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-}-findModuleFile :: [FilePath]  -- ^ build prefix (location of objects)-               -> [String]    -- ^ search suffixes-               -> ModuleName  -- ^ module-               -> IO (FilePath, FilePath)-findModuleFile = findModuleFileEx normal---- | Find the file corresponding to a Haskell module name.------ This is similar to 'findFileWithExtension'' but specialised to a module--- name. The function fails if the file corresponding to the module is missing.----findModuleFileEx :: Verbosity-                 -> [FilePath]  -- ^ build prefix (location of objects)-                 -> [String]    -- ^ search suffixes-                 -> ModuleName  -- ^ module-                 -> IO (FilePath, FilePath)-findModuleFileEx verbosity searchPath extensions mod_name =-      maybe notFound return-  =<< findFileWithExtension' extensions searchPath-                             (ModuleName.toFilePath mod_name)-  where-    notFound = die' verbosity $-      "Error: Could not find module: " ++ prettyShow mod_name-      ++ " with any suffix: "          ++ show extensions-      ++ " in the search path: "       ++ show searchPath---- | List all the files in a directory and all subdirectories.------ The order places files in sub-directories after all the files in their--- parent directories. The list is generated lazily so is not well defined if--- the source directory structure changes before the list is used.----getDirectoryContentsRecursive :: FilePath -> IO [FilePath]-getDirectoryContentsRecursive topdir = recurseDirectories [""]-  where-    recurseDirectories :: [FilePath] -> IO [FilePath]-    recurseDirectories []         = return []-    recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do-      (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)-      files' <- recurseDirectories (dirs' ++ dirs)-      return (files ++ files')--      where-        collect files dirs' []              = return (reverse files-                                                     ,reverse dirs')-        collect files dirs' (entry:entries) | ignore entry-                                            = collect files dirs' entries-        collect files dirs' (entry:entries) = do-          let dirEntry = dir </> entry-          isDirectory <- doesDirectoryExist (topdir </> dirEntry)-          if isDirectory-            then collect files (dirEntry:dirs') entries-            else collect (dirEntry:files) dirs' entries--        ignore ['.']      = True-        ignore ['.', '.'] = True-        ignore _          = False----------------------------- Environment variables---- | Is this directory in the system search path?-isInSearchPath :: FilePath -> IO Bool-isInSearchPath path = fmap (elem path) getSearchPath--addLibraryPath :: OS-               -> [FilePath]-               -> [(String,String)]-               -> [(String,String)]-addLibraryPath os paths = addEnv-  where-    pathsString = intercalate [searchPathSeparator] paths-    ldPath = case os of-               OSX -> "DYLD_LIBRARY_PATH"-               _   -> "LD_LIBRARY_PATH"--    addEnv [] = [(ldPath,pathsString)]-    addEnv ((key,value):xs)-      | key == ldPath =-          if null value-             then (key,pathsString):xs-             else (key,value ++ (searchPathSeparator:pathsString)):xs-      | otherwise     = (key,value):addEnv xs------------------------- Modification time---- | Compare the modification times of two files to see if the first is newer--- than the second. The first file must exist but the second need not.--- The expected use case is when the second file is generated using the first.--- In this use case, if the result is True then the second file is out of date.----moreRecentFile :: FilePath -> FilePath -> IO Bool-moreRecentFile a b = do-  exists <- doesFileExist b-  if not exists-    then return True-    else do tb <- getModificationTime b-            ta <- getModificationTime a-            return (ta > tb)---- | Like 'moreRecentFile', but also checks that the first file exists.-existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool-existsAndIsMoreRecentThan a b = do-  exists <- doesFileExist a-  if not exists-    then return False-    else a `moreRecentFile` b--------------------------------------------- Copying and installing files and dirs---- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels.----createDirectoryIfMissingVerbose :: Verbosity-                                -> Bool     -- ^ Create its parents too?-                                -> FilePath-                                -> IO ()-createDirectoryIfMissingVerbose verbosity create_parents path0-  | create_parents = withFrozenCallStack $ createDirs (parents path0)-  | otherwise      = withFrozenCallStack $ createDirs (take 1 (parents path0))-  where-    parents = reverse . scanl1 (</>) . splitDirectories . normalise--    createDirs []         = return ()-    createDirs (dir:[])   = createDir dir throwIO-    createDirs (dir:dirs) =-      createDir dir $ \_ -> do-        createDirs dirs-        createDir dir throwIO--    createDir :: FilePath -> (IOException -> IO ()) -> IO ()-    createDir dir notExistHandler = do-      r <- tryIO $ createDirectoryVerbose verbosity dir-      case (r :: Either IOException ()) of-        Right ()                   -> return ()-        Left  e-          | isDoesNotExistError  e -> notExistHandler e-          -- createDirectory (and indeed POSIX mkdir) does not distinguish-          -- between a dir already existing and a file already existing. So we-          -- check for it here. Unfortunately there is a slight race condition-          -- here, but we think it is benign. It could report an exception in-          -- the case that the dir did exist but another process deletes the-          -- directory and creates a file in its place before we can check-          -- that the directory did indeed exist.-          | isAlreadyExistsError e -> (do-              isDir <- doesDirectoryExist dir-              unless isDir $ throwIO e-              ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())-          | otherwise              -> throwIO e--createDirectoryVerbose :: Verbosity -> FilePath -> IO ()-createDirectoryVerbose verbosity dir = withFrozenCallStack $ do-  info verbosity $ "creating " ++ dir-  createDirectory dir-  setDirOrdinary dir---- | Copies a file without copying file permissions. The target file is created--- with default permissions. Any existing target file is replaced.------ At higher verbosity levels it logs an info message.----copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO ()-copyFileVerbose verbosity src dest = withFrozenCallStack $ do-  info verbosity ("copy " ++ src ++ " to " ++ dest)-  copyFile src dest---- | Install an ordinary file. This is like a file copy but the permissions--- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\"--- while on Windows it uses the default permissions for the target directory.----installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO ()-installOrdinaryFile verbosity src dest = withFrozenCallStack $ do-  info verbosity ("Installing " ++ src ++ " to " ++ dest)-  copyOrdinaryFile src dest---- | Install an executable file. This is like a file copy but the permissions--- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\"--- while on Windows it uses the default permissions for the target directory.----installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()-installExecutableFile verbosity src dest = withFrozenCallStack $ do-  info verbosity ("Installing executable " ++ src ++ " to " ++ dest)-  copyExecutableFile src dest---- | Install a file that may or not be executable, preserving permissions.-installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()-installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do-  perms <- getPermissions src-  if (executable perms) --only checks user x bit-    then installExecutableFile verbosity src dest-    else installOrdinaryFile   verbosity src dest---- | Given a relative path to a file, copy it to the given directory, preserving--- the relative path and creating the parent directories if needed.-copyFileTo :: Verbosity -> FilePath -> FilePath -> IO ()-copyFileTo verbosity dir file = withFrozenCallStack $ do-  let targetFile = dir </> file-  createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)-  installOrdinaryFile verbosity file targetFile---- | Common implementation of 'copyFiles', 'installOrdinaryFiles',--- 'installExecutableFiles' and 'installMaybeExecutableFiles'.-copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ())-              -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()-copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do--  -- Create parent directories for everything-  let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles-  traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs--  -- Copy all the files-  sequence_ [ let src  = srcBase   </> srcFile-                  dest = targetDir </> srcFile-               in doCopy verbosity src dest-            | (srcBase, srcFile) <- srcFiles ]---- | Copies a bunch of files to a target directory, preserving the directory--- structure in the target location. The target directories are created if they--- do not exist.------ The files are identified by a pair of base directory and a path relative to--- that base. It is only the relative part that is preserved in the--- destination.------ For example:------ > copyFiles normal "dist/src"--- >    [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")]------ This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and--- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\".------ This operation is not atomic. Any IO failure during the copy (including any--- missing source files) leaves the target in an unknown state so it is best to--- use it with a freshly created directory so that it can be simply deleted if--- anything goes wrong.----copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()-copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs)---- | This is like 'copyFiles' but uses 'installOrdinaryFile'.----installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()-installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs)---- | This is like 'copyFiles' but uses 'installExecutableFile'.----installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]-                          -> IO ()-installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs)---- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'.----installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]-                               -> IO ()-installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs)---- | This installs all the files in a directory to a target location,--- preserving the directory layout. All the files are assumed to be ordinary--- rather than executable files.----installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO ()-installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do-  info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")-  srcFiles <- getDirectoryContentsRecursive srcDir-  installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]---- | Recursively copy the contents of one directory to another path.-copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO ()-copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do-  info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")-  srcFiles <- getDirectoryContentsRecursive srcDir-  copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f)-                                                   | f <- srcFiles ]------------------------ File permissions---- | Like 'doesFileExist', but also checks that the file is executable.-doesExecutableExist :: FilePath -> IO Bool-doesExecutableExist f = do-  exists <- doesFileExist f-  if exists-    then do perms <- getPermissions f-            return (executable perms)-    else return False-------------------------------- Temporary files and dirs---- | Advanced options for 'withTempFile' and 'withTempDirectory'.-data TempFileOptions = TempFileOptions {-  optKeepTempFiles :: Bool  -- ^ Keep temporary files?-  }--defaultTempFileOptions :: TempFileOptions-defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False }---- | Use a temporary filename that doesn't already exist.----withTempFile :: FilePath    -- ^ Temp dir to create the file in-                -> String   -- ^ File name template. See 'openTempFile'.-                -> (FilePath -> Handle -> IO a) -> IO a-withTempFile tmpDir template action =-  withTempFileEx defaultTempFileOptions tmpDir template action---- | A version of 'withTempFile' that additionally takes a 'TempFileOptions'--- argument.-withTempFileEx :: TempFileOptions-                 -> FilePath -- ^ Temp dir to create the file in-                 -> String   -- ^ File name template. See 'openTempFile'.-                 -> (FilePath -> Handle -> IO a) -> IO a-withTempFileEx opts tmpDir template action =-  Exception.bracket-    (openTempFile tmpDir template)-    (\(name, handle) -> do hClose handle-                           unless (optKeepTempFiles opts) $-                             handleDoesNotExist () . removeFile $ name)-    (withLexicalCallStack (\x -> uncurry action x))---- | Create and use a temporary directory.------ Creates a new temporary directory inside the given directory, making use--- of the template. The temp directory is deleted after use. For example:------ > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ...------ The @tmpDir@ will be a new subdirectory of the given directory, e.g.--- @src/sdist.342@.----withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a-withTempDirectory verbosity targetDir template f = withFrozenCallStack $-  withTempDirectoryEx verbosity defaultTempFileOptions targetDir template-    (withLexicalCallStack (\x -> f x))---- | A version of 'withTempDirectory' that additionally takes a--- 'TempFileOptions' argument.-withTempDirectoryEx :: Verbosity -> TempFileOptions-                       -> FilePath -> String -> (FilePath -> IO a) -> IO a-withTempDirectoryEx _verbosity opts targetDir template f = withFrozenCallStack $-  Exception.bracket-    (createTempDirectory targetDir template)-    (unless (optKeepTempFiles opts)-     . handleDoesNotExist () . removeDirectoryRecursive)-    (withLexicalCallStack (\x -> f x))---------------------------------------- Safely reading and writing files---- | Write a file but only if it would have new content. If we would be writing--- the same as the existing content then leave the file as is so that we do not--- update the file's modification time.------ NB: Before Cabal-3.0 the file content was assumed to be---     ASCII-representable. Since Cabal-3.0 the file is assumed to be---     UTF-8 encoded.-rewriteFileEx :: Verbosity -> FilePath -> String -> IO ()-rewriteFileEx verbosity path =-  rewriteFileLBS verbosity path . toUTF8LBS---- | Same as `rewriteFileEx` but for 'ByteString's.-rewriteFileLBS :: Verbosity -> FilePath -> BS.ByteString -> IO ()-rewriteFileLBS verbosity path newContent =-  flip catchIO mightNotExist $ do-    existingContent <- annotateIO verbosity $ BS.readFile path-    _ <- evaluate (BS.length existingContent)-    unless (existingContent == newContent) $-      annotateIO verbosity $-        writeFileAtomic path newContent-  where-    mightNotExist e | isDoesNotExistError e-                    = annotateIO verbosity $ writeFileAtomic path newContent-                    | otherwise-                    = ioError e----- | The path name that represents the current directory.--- In Unix, it's @\".\"@, but this is system-specific.--- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.)-currentDir :: FilePath-currentDir = "."--shortRelativePath :: FilePath -> FilePath -> FilePath-shortRelativePath from to =-    case dropCommonPrefix (splitDirectories from) (splitDirectories to) of-        (stuff, path) -> joinPath (map (const "..") stuff ++ path)-  where-    dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a])-    dropCommonPrefix (x:xs) (y:ys)-        | x == y    = dropCommonPrefix xs ys-    dropCommonPrefix xs ys = (xs,ys)---- | Drop the extension if it's one of 'exeExtensions', or return the path--- unchanged.-dropExeExtension :: FilePath -> FilePath-dropExeExtension filepath =-  -- System.FilePath's extension handling functions are horribly-  -- inconsistent, consider:-  ---  --     isExtensionOf "" "foo"  == False but-  --     isExtensionOf "" "foo." == True.-  ---  -- On the other hand stripExtension doesn't remove the empty extension:-  ---  --    stripExtension "" "foo." == Just "foo."-  ---  -- Since by "" in exeExtensions we mean 'no extension' anyways we can-  -- just always ignore it here.-  let exts = [ ext | ext <- exeExtensions, ext /= "" ] in-  fromMaybe filepath $ do-    ext <- find (`FilePath.isExtensionOf` filepath) exts-    ext `FilePath.stripExtension` filepath---- | List of possible executable file extensions on the current build--- platform.-exeExtensions :: [String]-exeExtensions = case buildOS of-  -- Possible improvement: on Windows, read the list of extensions from the-  -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat;-  -- .cmd".-  Windows -> ["", "exe"]-  Ghcjs   -> ["", "exe"]-  _       -> [""]---- --------------------------------------------------------------- * Finding the description file--- ---------------------------------------------------------------- | Package description file (/pkgname/@.cabal@)-defaultPackageDesc :: Verbosity -> IO FilePath-defaultPackageDesc verbosity = tryFindPackageDesc verbosity currentDir---- |Find a package description file in the given directory.  Looks for--- @.cabal@ files.-findPackageDesc :: FilePath                    -- ^Where to look-                -> IO (Either String FilePath) -- ^<pkgname>.cabal-findPackageDesc = findPackageDescCwd "."---- | @since 3.4.0.0-findPackageDescCwd-    :: FilePath                    -- ^ project root-    -> FilePath                    -- ^ relative directory-    -> IO (Either String FilePath) -- ^ <pkgname>.cabal relative to the project root-findPackageDescCwd cwd dir- = do files <- getDirectoryContents (cwd </> dir)-      -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal-      -- file we filter to exclude dirs and null base file names:-      cabalFiles <- filterM (doesFileExist . snd)-                       [ (dir </> file, cwd </> dir </> file)-                       | file <- files-                       , let (name, ext) = splitExtension file-                       , not (null name) && ext == ".cabal" ]-      case map fst cabalFiles of-        []          -> return (Left  noDesc)-        [cabalFile] -> return (Right cabalFile)-        multiple    -> return (Left  $ multiDesc multiple)--  where-    noDesc :: String-    noDesc = "No cabal file found.\n"-             ++ "Please create a package description file <pkgname>.cabal"--    multiDesc :: [String] -> String-    multiDesc l = "Multiple cabal files found.\n"-                  ++ "Please use only one of: "-                  ++ intercalate ", " l---- |Like 'findPackageDesc', but calls 'die' in case of error.-tryFindPackageDesc :: Verbosity -> FilePath -> IO FilePath-tryFindPackageDesc verbosity dir =-  either (die' verbosity) return =<< findPackageDesc dir---- | Like 'findPackageDescCwd', but calls 'die' in case of error.------ @since 3.4.0.0-tryFindPackageDescCwd :: Verbosity -> FilePath -> FilePath -> IO FilePath-tryFindPackageDescCwd verbosity cwd dir =-  either (die' verbosity) return =<< findPackageDescCwd cwd dir---- |Find auxiliary package information in the given directory.--- Looks for @.buildinfo@ files.-findHookedPackageDesc-    :: Verbosity-    -> FilePath                 -- ^Directory to search-    -> IO (Maybe FilePath)      -- ^/dir/@\/@/pkgname/@.buildinfo@, if present-findHookedPackageDesc verbosity dir = do-    files <- getDirectoryContents dir-    buildInfoFiles <- filterM doesFileExist-                        [ dir </> file-                        | file <- files-                        , let (name, ext) = splitExtension file-                        , not (null name) && ext == buildInfoExt ]-    case buildInfoFiles of-        []  -> return Nothing-        [f] -> return (Just f)-        _   -> die' verbosity ("Multiple files with extension " ++ buildInfoExt)--buildInfoExt  :: String-buildInfoExt = ".buildinfo"+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+#ifdef GIT_REV+{-# LANGUAGE TemplateHaskell #-}+#endif++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Utils+-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004+-- License     :  BSD3+--                portions Copyright (c) 2007, Galois Inc.+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- A large and somewhat miscellaneous collection of utility functions used+-- throughout the rest of the Cabal lib and in other tools that use the Cabal+-- lib like @cabal-install@. It has a very simple set of logging actions. It+-- has low level functions for running programs, a bunch of wrappers for+-- various directory and file functions that do extra logging.+module Distribution.Simple.Utils+  ( cabalVersion+  , cabalGitInfo++    -- * logging and errors+  , dieNoVerbosity+  , die'+  , dieWithException+  , dieWithLocation'+  , dieNoWrap+  , topHandler+  , topHandlerWith+  , warn+  , warnError+  , notice+  , noticeNoWrap+  , noticeDoc+  , setupMessage+  , info+  , infoNoWrap+  , debug+  , debugNoWrap+  , chattyTry+  , annotateIO+  , exceptionWithMetadata+  , withOutputMarker++    -- * exceptions+  , handleDoesNotExist+  , ignoreSigPipe++    -- * running programs+  , rawSystemExit+  , rawSystemExitCode+  , rawSystemProc+  , rawSystemProcAction+  , rawSystemExitWithEnv+  , rawSystemExitWithEnvCwd+  , rawSystemStdout+  , rawSystemStdInOut+  , rawSystemIOWithEnv+  , rawSystemIOWithEnvAndAction+  , fromCreatePipe+  , maybeExit+  , xargs+  , findProgramVersion++    -- ** 'IOData' re-export++  --+  -- These types are re-exported from+  -- "Distribution.Utils.IOData" for convenience as they're+  -- exposed in the API of 'rawSystemStdInOut'+  , IOData (..)+  , KnownIODataMode (..)+  , IODataMode (..)+  , VerboseException (..)++    -- * copying files+  , createDirectoryIfMissingVerbose+  , copyFileVerbose+  , copyFiles+  , copyFileTo+  , copyFileToCwd++    -- * installing files+  , installOrdinaryFile+  , installExecutableFile+  , installMaybeExecutableFile+  , installOrdinaryFiles+  , installExecutableFiles+  , installMaybeExecutableFiles+  , installDirectoryContents+  , copyDirectoryRecursive++    -- * File permissions+  , doesExecutableExist+  , setFileOrdinary+  , setFileExecutable++    -- * file names+  , shortRelativePath+  , dropExeExtension+  , exeExtensions++    -- * finding files+  , findFileEx+  , findFileCwd+  , findFirstFile+  , Suffix (..)+  , findFileWithExtension+  , findFileCwdWithExtension+  , findFileWithExtension'+  , findFileCwdWithExtension'+  , findAllFilesWithExtension+  , findAllFilesCwdWithExtension+  , findModuleFileEx+  , findModuleFileCwd+  , findModuleFilesEx+  , findModuleFilesCwd+  , getDirectoryContentsRecursive++    -- * environment variables+  , isInSearchPath+  , addLibraryPath++    -- * modification time+  , moreRecentFile+  , existsAndIsMoreRecentThan++    -- * temp files and dirs+  , TempFileOptions (..)+  , defaultTempFileOptions+  , withTempFile+  , withTempFileCwd+  , withTempFileEx+  , withTempDirectory+  , withTempDirectoryCwd+  , withTempDirectoryEx+  , withTempDirectoryCwdEx+  , createTempDirectory++    -- * .cabal and .buildinfo files+  , defaultPackageDescCwd+  , findPackageDesc+  , tryFindPackageDesc+  , findHookedPackageDesc++    -- * reading and writing files safely+  , withFileContents+  , writeFileAtomic+  , rewriteFileEx+  , rewriteFileLBS++    -- * Unicode+  , fromUTF8BS+  , fromUTF8LBS+  , toUTF8BS+  , toUTF8LBS+  , readUTF8File+  , withUTF8FileContents+  , writeUTF8File+  , normaliseLineEndings++    -- * BOM+  , ignoreBOM++    -- * generic utils+  , dropWhileEndLE+  , takeWhileEndLE+  , equating+  , comparing+  , isInfixOf+  , intercalate+  , lowercase+  , listUnion+  , listUnionRight+  , ordNub+  , sortNub+  , ordNubBy+  , ordNubRight+  , safeHead+  , safeTail+  , safeLast+  , safeInit+  , unintersperse+  , wrapText+  , wrapLine+  , stripCommonPrefix++    -- * FilePath stuff+  , isAbsoluteOnAnyPlatform+  , isRelativeOnAnyPlatform+  , exceptionWithCallStackPrefix+  ) where++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.ModuleName as ModuleName+import Distribution.Simple.Errors+import Distribution.Simple.PreProcess.Types+import Distribution.System+import Distribution.Types.PackageId+import Distribution.Utils.Generic+import Distribution.Utils.IOData (IOData (..), IODataMode (..), KnownIODataMode (..))+import qualified Distribution.Utils.IOData as IOData+import Distribution.Utils.Path+import Distribution.Verbosity+import Distribution.Version+import Prelude ()++#ifdef CURRENT_PACKAGE_KEY+#define BOOTSTRAPPED_CABAL 1+#endif++#ifdef BOOTSTRAPPED_CABAL+import qualified Paths_Cabal (version)+#endif++import Distribution.Parsec+import Distribution.Pretty++import qualified Data.ByteString.Lazy as BS+import Data.Typeable+  ( cast+  )++import qualified Control.Exception as Exception+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)+import Distribution.Compat.Process (proc)+import Foreign.C.Error (Errno (..), ePIPE)+import qualified GHC.IO.Exception as GHC+import GHC.Stack (HasCallStack)+import Numeric (showFFloat)+import System.Directory+  ( Permissions (executable)+  , createDirectory+  , doesDirectoryExist+  , doesFileExist+  , getDirectoryContents+  , getModificationTime+  , getPermissions+  , getTemporaryDirectory+  , removeDirectoryRecursive+  , removeFile+  )+import System.Environment+  ( getProgName+  )+import System.FilePath (takeFileName)+import System.FilePath as FilePath+  ( getSearchPath+  , joinPath+  , normalise+  , searchPathSeparator+  , splitDirectories+  , splitExtension+  , takeDirectory+  )+import System.IO+  ( BufferMode (..)+  , Handle+  , hClose+  , hFlush+  , hGetContents+  , hPutStr+  , hPutStrLn+  , hSetBinaryMode+  , hSetBuffering+  , stderr+  , stdout+  )+import System.IO.Error+import System.IO.Unsafe+  ( unsafeInterleaveIO+  )+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++-- We only get our own version number when we're building with ourselves+cabalVersion :: Version+#if defined(BOOTSTRAPPED_CABAL)+cabalVersion = mkVersion' Paths_Cabal.version+#elif defined(CABAL_VERSION)+cabalVersion = mkVersion [CABAL_VERSION]+#else+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'+    branchInfo | isLeft gi' = ""+               | either id giBranch gi' == "master" = ""+               | otherwise = " on " <> either id giBranch gi'+#else+cabalGitInfo = ""+#endif++-- ----------------------------------------------------------------------------+-- Exception and logging utils++-- Cabal's logging infrastructure has a few constraints:+--+--  * We must make all logging formatting and emissions decisions based+--    on the 'Verbosity' parameter, which is the only parameter that is+--    plumbed to enough call-sites to actually be used for this matter.+--    (One of Cabal's "big mistakes" is to have never have defined a+--    monad of its own.)+--+--  * When we 'die', we must raise an IOError.  This a backwards+--    compatibility consideration, because that's what we've raised+--    previously, and if we change to any other exception type,+--    exception handlers which match on IOError will no longer work.+--    One case where it is known we rely on IOError being catchable+--    is 'readPkgConfigDb' in cabal-install; there may be other+--    user code that also assumes this.+--+--  * The 'topHandler' does not know what 'Verbosity' is, because+--    it gets called before we've done command line parsing (where+--    the 'Verbosity' parameter would come from).+--+-- This leads to two big architectural choices:+--+--  * Although naively we might imagine 'Verbosity' to be a simple+--    enumeration type, actually it is a full-on abstract data type+--    that may contain arbitrarily complex information.  At the+--    moment, it is fully representable as a string, but we might+--    eventually also use verbosity to let users register their+--    own logging handler.+--+--  * When we call 'die', we perform all the formatting and addition+--    of extra information we need, and then ship this in the IOError+--    to the top-level handler.  Here are alternate designs that+--    don't work:+--+--      a) Ship the unformatted info to the handler.  This doesn't+--      work because at the point the handler gets the message,+--      we've lost call stacks, and even if we did, we don't have access+--      to 'Verbosity' to decide whether or not to render it.+--+--      b) Print the information at the 'die' site, then raise an+--      error.  This means that if the exception is subsequently+--      caught by a handler, we will still have emitted the output,+--      which is not the correct behavior.+--+--    For the top-level handler to "know" that an error message+--    contains one of these fully formatted packets, we set a sentinel+--    in one of IOError's extra fields.  This is handled by+--    'ioeSetVerbatim' and 'ioeGetVerbatim'.+--++dieNoVerbosity :: String -> IO a+dieNoVerbosity msg =+  ioError (userError msg)+  where+    _ = callStack -- TODO: Attach CallStack to exception++-- | Tag an 'IOError' whose error string should be output to the screen+-- verbatim.+ioeSetVerbatim :: IOError -> IOError+ioeSetVerbatim e = ioeSetLocation e "dieVerbatim"++-- | Check if an 'IOError' should be output verbatim to screen.+ioeGetVerbatim :: IOError -> Bool+ioeGetVerbatim e = ioeGetLocation e == "dieVerbatim"++-- | Create a 'userError' whose error text will be output verbatim+verbatimUserError :: String -> IOError+verbatimUserError = ioeSetVerbatim . userError++dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a+dieWithLocation' verbosity filename mb_lineno msg =+  die' verbosity $+    filename+      ++ ( case mb_lineno of+            Just lineno -> ":" ++ show lineno+            Nothing -> ""+         )+      ++ ": "+      ++ msg++die' :: Verbosity -> String -> IO a+die' verbosity msg = withFrozenCallStack $ do+  ioError . verbatimUserError+    =<< annotateErrorString verbosity+    =<< pure . wrapTextVerbosity verbosity+    =<< pure . addErrorPrefix+    =<< prefixWithProgName msg++-- Type which will be a wrapper for cabal -exceptions and cabal-install exceptions+data VerboseException a = VerboseException CallStack POSIXTime Verbosity 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 verbosity exception = do+  ts <- getPOSIXTime+  throwIO $ VerboseException callStack ts verbosity exception++-- Instance for Cabal Exception which will display error code and error message with callStack info+instance Exception (VerboseException CabalException) where+  displayException :: VerboseException CabalException -> [Char]+  displayException (VerboseException stack timestamp verb cabalexception) =+    withOutputMarker+      verb+      ( concat+          [ "Error: [Cabal-"+          , show (exceptionCode cabalexception)+          , "]\n"+          ]+      )+      ++ exceptionWithMetadata stack timestamp verb (exceptionMessage cabalexception)++dieNoWrap :: Verbosity -> String -> IO a+dieNoWrap verbosity msg = withFrozenCallStack $ do+  -- TODO: should this have program name or not?+  ioError . verbatimUserError+    =<< annotateErrorString+      verbosity+      (addErrorPrefix msg)++-- | Prefixing a message to indicate that it is a fatal error,+-- if the 'errorPrefix' is not already present.+addErrorPrefix :: String -> String+addErrorPrefix msg+  | errorPrefix `isPrefixOf` msg = msg+  -- Backpack prefixes its errors already with "Error:", see+  -- 'Distribution.Utils.LogProgress.dieProgress'.+  -- Taking it away there destroys the layout, so we rather+  -- check here whether the prefix is already present.+  | otherwise = unwords [errorPrefix, msg]++-- | A prefix indicating that a message is a fatal error.+errorPrefix :: String+errorPrefix = "Error:"++-- | Prefix an error string with program name from 'getProgName'+prefixWithProgName :: String -> IO String+prefixWithProgName msg = do+  pname <- getProgName+  return $ pname ++ ": " ++ msg++-- | Annotate an error string with timestamp and 'withMetadata'.+annotateErrorString :: Verbosity -> String -> IO String+annotateErrorString verbosity msg = do+  ts <- getPOSIXTime+  return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg++-- | Given a block of IO code that may raise an exception, annotate+-- it with the metadata from the current scope.  Use this as close+-- to external code that raises IO exceptions as possible, since+-- this function unconditionally wraps the error message with a trace+-- (so it is NOT idempotent.)+annotateIO :: Verbosity -> IO a -> IO a+annotateIO verbosity act = do+  ts <- getPOSIXTime+  flip modifyIOError act $+    ioeModifyErrorString $+      withMetadata ts NeverMark VerboseTrace verbosity++-- | A semantic editor for the error message inside an 'IOError'.+ioeModifyErrorString :: (String -> String) -> IOError -> IOError+ioeModifyErrorString = over ioeErrorString++-- | A lens for the error message inside an 'IOError'.+ioeErrorString :: Lens' IOError String+ioeErrorString f ioe = ioeSetErrorString ioe <$> f (ioeGetErrorString ioe)++{-# NOINLINE topHandlerWith #-}+topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a+topHandlerWith cont prog = do+  -- By default, stderr to a terminal device is NoBuffering. But this+  -- is *really slow*+  hSetBuffering stderr LineBuffering+  Exception.catches+    prog+    [ Exception.Handler rethrowAsyncExceptions+    , Exception.Handler rethrowExitStatus+    , Exception.Handler handle+    ]+  where+    -- Let async exceptions rise to the top for the default top-handler+    rethrowAsyncExceptions :: Exception.AsyncException -> IO a+    rethrowAsyncExceptions a = throwIO a++    -- ExitCode gets thrown asynchronously too, and we don't want to print it+    rethrowExitStatus :: ExitCode -> IO a+    rethrowExitStatus = throwIO++    -- Print all other exceptions+    handle :: Exception.SomeException -> IO a+    handle se = do+      hFlush stdout+      pname <- getProgName+      hPutStr stderr (message pname se)+      cont se++    message :: String -> Exception.SomeException -> String+    message pname (Exception.SomeException se) =+      case cast se :: Maybe Exception.IOException of+        Just ioe+          | ioeGetVerbatim ioe ->+              -- Use the message verbatim+              ioeGetErrorString ioe ++ "\n"+          | isUserError ioe ->+              let file = case ioeGetFileName ioe of+                    Nothing -> ""+                    Just path -> path ++ location ++ ": "+                  location = case ioeGetLocation ioe of+                    l@(n : _) | isDigit n -> ':' : l+                    _ -> ""+                  detail = ioeGetErrorString ioe+               in wrapText $ addErrorPrefix $ pname ++ ": " ++ file ++ detail+        _ ->+          displaySomeException se ++ "\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++-- | Depending on 'isVerboseStderr', set the output handle to 'stderr' or 'stdout'.+verbosityHandle :: Verbosity -> Handle+verbosityHandle verbosity+  | isVerboseStderr verbosity = stderr+  | otherwise = stdout++-- | Non fatal conditions that may be indicative of an error or problem.+--+-- We display these at the 'normal' verbosity level.+warn :: Verbosity -> String -> IO ()+warn verbosity msg = warnMessage "Warning" verbosity msg++-- | 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 ()+warnError verbosity message = warnMessage "Error" verbosity message++-- | Warning message, with a custom label.+warnMessage :: String -> Verbosity -> String -> IO ()+warnMessage l verbosity msg = withFrozenCallStack $ do+  when ((verbosity >= normal) && not (isVerboseNoWarn verbosity)) $ do+    ts <- getPOSIXTime+    hFlush stdout+    hPutStr stderr+      . withMetadata ts NormalMark FlagTrace verbosity+      . wrapTextVerbosity verbosity+      $ l ++ ": " ++ msg++-- | Useful status messages.+--+-- We display these at the 'normal' verbosity level.+--+-- This is for the ordinary helpful status messages that users see. Just+-- enough information to know that things are working but not floods of detail.+notice :: Verbosity -> String -> IO ()+notice verbosity msg = withFrozenCallStack $ do+  when (verbosity >= normal) $ do+    let h = verbosityHandle verbosity+    ts <- getPOSIXTime+    hPutStr h $+      withMetadata ts NormalMark FlagTrace verbosity $+        wrapTextVerbosity verbosity $+          msg++-- | 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+    ts <- getPOSIXTime+    hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ 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+    ts <- getPOSIXTime+    hPutStr h $+      withMetadata ts NormalMark FlagTrace verbosity $+        Disp.renderStyle defaultStyle $+          msg++-- | Display a "setup status message".  Prefer using setupMessage'+-- if possible.+setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()+setupMessage verbosity msg pkgid = withFrozenCallStack $ do+  noticeNoWrap verbosity (msg ++ ' ' : prettyShow pkgid ++ "...")++-- | More detail on the operation of some action.+--+-- We display these messages when the verbosity level is 'verbose'+info :: Verbosity -> String -> IO ()+info verbosity msg = withFrozenCallStack $+  when (verbosity >= verbose) $ do+    let h = verbosityHandle verbosity+    ts <- getPOSIXTime+    hPutStr h $+      withMetadata ts NeverMark FlagTrace verbosity $+        wrapTextVerbosity verbosity $+          msg++infoNoWrap :: Verbosity -> String -> IO ()+infoNoWrap verbosity msg = withFrozenCallStack $+  when (verbosity >= verbose) $ do+    let h = verbosityHandle verbosity+    ts <- getPOSIXTime+    hPutStr h $+      withMetadata ts NeverMark FlagTrace verbosity $+        msg++-- | Detailed internal debugging information+--+-- We display these messages when the verbosity level is 'deafening'+debug :: Verbosity -> String -> IO ()+debug verbosity msg = withFrozenCallStack $+  when (verbosity >= deafening) $ do+    let h = verbosityHandle verbosity+    ts <- getPOSIXTime+    hPutStr h $+      withMetadata ts NeverMark FlagTrace verbosity $+        wrapTextVerbosity verbosity $+          msg+    -- ensure that we don't lose output if we segfault/infinite loop+    hFlush stdout++-- | A variant of 'debug' that doesn't perform the automatic line+-- wrapping. Produces better output in some cases.+debugNoWrap :: Verbosity -> String -> IO ()+debugNoWrap verbosity msg = withFrozenCallStack $+  when (verbosity >= deafening) $ do+    let h = verbosityHandle verbosity+    ts <- getPOSIXTime+    hPutStr h $+      withMetadata ts NeverMark FlagTrace verbosity $+        msg+    -- ensure that we don't lose output if we segfault/infinite loop+    hFlush stdout++-- | Perform an IO action, catching any IO exceptions and printing an error+--   if one occurs.+chattyTry+  :: String+  -- ^ a description of the action we were attempting+  -> IO ()+  -- ^ the action itself+  -> IO ()+chattyTry desc action =+  catchIO action $ \exception ->+    hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception++-- | Run an IO computation, returning @e@ if it raises a "file+-- does not exist" error.+handleDoesNotExist :: a -> IO a -> IO a+handleDoesNotExist e =+  Exception.handleJust+    (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing)+    (\_ -> return e)++-- -----------------------------------------------------------------------------+-- Helper functions++-- | Wraps text unless the @+nowrap@ verbosity flag is active+wrapTextVerbosity :: Verbosity -> String -> String+wrapTextVerbosity verb+  | isVerboseNoWrap verb = withTrailingNewline+  | otherwise = withTrailingNewline . wrapText++-- | Prepends a timestamp if @+timestamp@ verbosity flag is set+--+-- This is used by 'withMetadata'+withTimestamp :: Verbosity -> POSIXTime -> String -> String+withTimestamp v ts msg+  | isVerboseTimestamp v = msg'+  | otherwise = msg -- no-op+  where+    msg' = case lines msg of+      [] -> tsstr "\n"+      l1 : rest -> unlines (tsstr (' ' : l1) : map (contpfx ++) rest)++    -- format timestamp to be prepended to first line with msec precision+    tsstr = showFFloat (Just 3) (realToFrac ts :: Double)++    -- continuation prefix for subsequent lines of msg+    contpfx = replicate (length (tsstr " ")) ' '++-- | Wrap output with a marker if @+markoutput@ verbosity flag is set.+--+-- NB: Why is markoutput done with start/end markers, and not prefixes?+-- Markers are more convenient to add (if we want to add prefixes,+-- we have to 'lines' and then 'map'; here's it's just some+-- concatenates).  Note that even in the prefix case, we can't+-- guarantee that the markers are unambiguous, because some of+-- Cabal's output comes straight from external programs, where+-- we don't have the ability to interpose on the output.+--+-- This is used by 'withMetadata'+withOutputMarker :: Verbosity -> String -> String+withOutputMarker v xs | not (isVerboseMarkOutput v) = xs+withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly+withOutputMarker _ xs =+  "-----BEGIN CABAL OUTPUT-----\n"+    ++ withTrailingNewline xs+    ++ "-----END CABAL OUTPUT-----\n"++-- | Append a trailing newline to a string if it does not+-- already have a trailing newline.+withTrailingNewline :: String -> String+withTrailingNewline "" = ""+withTrailingNewline (x : xs) = x : go x xs+  where+    go _ (c : cs) = c : go c cs+    go '\n' "" = ""+    go _ "" = "\n"++-- | Prepend a call-site and/or call-stack based on Verbosity+withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String)+withCallStackPrefix tracer verbosity s =+  withFrozenCallStack $+    ( if isVerboseCallSite verbosity+        then+          parentSrcLocPrefix+            +++            -- Hack: need a newline before starting output marker :(+            if isVerboseMarkOutput verbosity+              then "\n"+              else ""+        else ""+    )+      ++ ( case traceWhen verbosity tracer of+            Just pre -> pre ++ prettyCallStack callStack ++ "\n"+            Nothing -> ""+         )+      ++ s++-- | When should we emit the call stack?  We always emit+-- for internal errors, emit the trace for errors when we+-- are in verbose mode, and otherwise only emit it if+-- explicitly asked for using the @+callstack@ verbosity+-- flag.  (At the moment, 'AlwaysTrace' is not used.+data TraceWhen+  = AlwaysTrace+  | VerboseTrace+  | FlagTrace+  deriving (Eq)++-- | Determine if we should emit a call stack.+-- If we trace, it also emits any prefix we should append.+traceWhen :: Verbosity -> TraceWhen -> Maybe String+traceWhen _ AlwaysTrace = Just ""+traceWhen v VerboseTrace | v >= verbose = Just ""+traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n"+traceWhen _ _ = Nothing++-- | When should we output the marker?  Things like 'die'+-- always get marked, but a 'NormalMark' will only be+-- output if we're not a quiet verbosity.+data MarkWhen = AlwaysMark | NormalMark | NeverMark++-- | Add all necessary metadata to a logging message+withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)+withMetadata ts marker tracer verbosity x =+  withFrozenCallStack+    $+    -- NB: order matters.  Output marker first because we+    -- don't want to capture call stacks.+    withTrailingNewline+      . withCallStackPrefix tracer verbosity+      . ( case marker of+            AlwaysMark -> withOutputMarker verbosity+            NormalMark+              | not (isVerboseQuiet verbosity) ->+                  withOutputMarker verbosity+              | otherwise ->+                  id+            NeverMark -> id+        )+      -- Clear out any existing markers+      . clearMarkers+      . withTimestamp verbosity ts+    $ x++-- | Add all necessary metadata to a logging message+exceptionWithMetadata :: CallStack -> POSIXTime -> Verbosity -> String -> String+exceptionWithMetadata stack ts verbosity x =+  withTrailingNewline+    . exceptionWithCallStackPrefix stack verbosity+    . withOutputMarker verbosity+    . clearMarkers+    . withTimestamp verbosity ts+    $ x++clearMarkers :: String -> String+clearMarkers s = unlines . filter isMarker $ lines s+  where+    isMarker "-----BEGIN CABAL OUTPUT-----" = False+    isMarker "-----END CABAL OUTPUT-----" = False+    isMarker _ = True++-- | Append a call-site and/or call-stack based on Verbosity+exceptionWithCallStackPrefix :: CallStack -> Verbosity -> String -> String+exceptionWithCallStackPrefix stack verbosity s =+  s+    ++ withFrozenCallStack+      ( ( if isVerboseCallSite verbosity+            then+              parentSrcLocPrefix+                +++                -- Hack: need a newline before starting output marker :(+                if isVerboseMarkOutput verbosity+                  then "\n"+                  else ""+            else ""+        )+          ++ ( if verbosity >= verbose+                then prettyCallStack stack ++ "\n"+                else ""+             )+      )++-- -----------------------------------------------------------------------------+-- rawSystem variants+--+-- These all use 'Distribution.Compat.Process.proc' to ensure we+-- consistently use process jobs on Windows and Ctrl-C delegation+-- on Unix.+--+-- Additionally, they take care of logging command execution.+--++-- | Helper to use with one of the 'rawSystem' variants, and exit+-- unless the command completes successfully.+maybeExit :: IO ExitCode -> IO ()+maybeExit cmd = do+  exitcode <- cmd+  unless (exitcode == ExitSuccess) $ exitWith exitcode++-- | Log a command execution (that's typically about to happen)+-- at info level, and log working directory and environment overrides+-- at debug level if specified.+logCommand :: Verbosity -> Process.CreateProcess -> IO ()+logCommand verbosity cp = do+  infoNoWrap verbosity $+    "Running: " <> case Process.cmdspec cp of+      Process.ShellCommand sh -> sh+      Process.RawCommand path args -> Process.showCommandForUser path args+  case Process.env cp of+    Just env -> debugNoWrap verbosity $ "with environment: " ++ show env+    Nothing -> return ()+  case Process.cwd cp of+    Just cwd -> debugNoWrap verbosity $ "with working directory: " ++ show cwd+    Nothing -> return ()+  hFlush stdout++-- | Execute the given command with the given arguments, exiting+-- with the same exit code if the command fails.+rawSystemExit :: Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> FilePath -> [String] -> IO ()+rawSystemExit verbosity mbWorkDir path args =+  withFrozenCallStack $+    maybeExit $+      rawSystemExitCode verbosity mbWorkDir path args Nothing++-- | Execute the given command with the given arguments, returning+-- the command's exit code.+rawSystemExitCode+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> 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+        }++-- | Execute the given command with the given arguments, returning+-- the command's exit code.+--+-- Create the process argument with 'Distribution.Compat.Process.proc'+-- to ensure consistent options with other 'rawSystem' functions in this+-- module.+rawSystemProc :: Verbosity -> Process.CreateProcess -> IO ExitCode+rawSystemProc verbosity cp = withFrozenCallStack $ do+  (exitcode, _) <- rawSystemProcAction verbosity cp $ \_ _ _ -> return ()+  return exitcode++-- | Execute the given command with the given arguments, returning+-- the command's exit code. 'action' is executed while the command+-- is running, and would typically be used to communicate with the+-- process through pipes.+--+-- Create the process argument with 'Distribution.Compat.Process.proc'+-- to ensure consistent options with other 'rawSystem' functions in this+-- module.+rawSystemProcAction+  :: Verbosity+  -> Process.CreateProcess+  -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)+  -> IO (ExitCode, a)+rawSystemProcAction verbosity cp action = withFrozenCallStack $ do+  logCommand verbosity cp+  (exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do+    a <- action mStdin mStdout mStderr+    exitcode <- Process.waitForProcess p+    return (exitcode, a)+  unless (exitcode == ExitSuccess) $ do+    let cmd = case Process.cmdspec cp of+          Process.ShellCommand sh -> sh+          Process.RawCommand path _args -> path+    debug verbosity $ cmd ++ " returned " ++ show exitcode+  return (exitcode, a)++-- | fromJust for dealing with 'Maybe Handle' values as obtained via+-- 'System.Process.CreatePipe'. Creating a pipe using 'CreatePipe' guarantees+-- a 'Just' value for the corresponding handle.+fromCreatePipe :: Maybe Handle -> Handle+fromCreatePipe = maybe (error "fromCreatePipe: Nothing") id++-- | Execute the given command with the given arguments and+-- environment, exiting with the same exit code if the command fails.+rawSystemExitWithEnv+  :: Verbosity+  -> FilePath+  -> [String]+  -> [(String, String)]+  -> IO ()+rawSystemExitWithEnv verbosity =+  rawSystemExitWithEnvCwd verbosity Nothing++-- | Like 'rawSystemExitWithEnv', but setting a working directory.+rawSystemExitWithEnvCwd+  :: Verbosity+  -> Maybe (SymbolicPath CWD to)+  -> FilePath+  -> [String]+  -> [(String, String)]+  -> IO ()+rawSystemExitWithEnvCwd verbosity mbWorkDir path args env =+  withFrozenCallStack $+    maybeExit $+      rawSystemProc verbosity $+        (proc path args)+          { Process.env = Just env+          , Process.cwd = getSymbolicPath <$> mbWorkDir+          }++-- | Execute the given command with the given arguments, returning+-- the command's exit code.+--+-- Optional arguments allow setting working directory, environment+-- and input and output handles.+rawSystemIOWithEnv+  :: Verbosity+  -> FilePath+  -> [String]+  -> Maybe FilePath+  -- ^ New working dir or inherit+  -> Maybe [(String, String)]+  -- ^ New environment or inherit+  -> Maybe Handle+  -- ^ stdin+  -> Maybe Handle+  -- ^ stdout+  -> Maybe Handle+  -- ^ stderr+  -> IO ExitCode+rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do+  (exitcode, _) <-+    rawSystemIOWithEnvAndAction+      verbosity+      path+      args+      mcwd+      menv+      action+      inp+      out+      err+  return exitcode+  where+    action = return ()++-- | Execute the given command with the given arguments, returning+-- the command's exit code. 'action' is executed while the command+-- is running, and would typically be used to communicate with the+-- process through pipes.+--+-- Optional arguments allow setting working directory, environment+-- and input and output handles.+rawSystemIOWithEnvAndAction+  :: Verbosity+  -> FilePath+  -> [String]+  -> Maybe FilePath+  -- ^ New working dir or inherit+  -> Maybe [(String, String)]+  -- ^ New environment or inherit+  -> IO a+  -- ^ action to perform after process is created, but before 'waitForProcess'.+  -> Maybe Handle+  -- ^ stdin+  -> Maybe Handle+  -- ^ stdout+  -> Maybe Handle+  -- ^ stderr+  -> IO (ExitCode, a)+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++-- | Execute the given command with the given arguments, returning+-- the command's output. Exits if the command exits with error.+--+-- Provides control over the binary/text mode of the output.+rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode+rawSystemStdout verbosity path args = withFrozenCallStack $ do+  (output, errors, exitCode) <-+    rawSystemStdInOut+      verbosity+      path+      args+      Nothing+      Nothing+      Nothing+      (IOData.iodataMode :: IODataMode mode)+  when (exitCode /= ExitSuccess) $+    dieWithException verbosity $+      RawSystemStdout errors+  return output++-- | Execute the given command with the given arguments, returning+-- the command's output, errors and exit code.+--+-- Optional arguments allow setting working directory, environment+-- and command input.+--+-- Provides control over the binary/text mode of the input and output.+rawSystemStdInOut+  :: KnownIODataMode mode+  => Verbosity+  -> FilePath+  -- ^ Program location+  -> [String]+  -- ^ Arguments+  -> Maybe FilePath+  -- ^ New working dir or inherit+  -> Maybe [(String, String)]+  -- ^ New environment or inherit+  -> Maybe IOData+  -- ^ input text and binary mode+  -> IODataMode mode+  -- ^ iodata mode, acts as proxy+  -> IO (mode, String, ExitCode)+  -- ^ output, errors, exit+rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do+  let cp =+        (proc path args)+          { Process.cwd = mcwd+          , Process.env = menv+          , Process.std_in = Process.CreatePipe+          , Process.std_out = Process.CreatePipe+          , Process.std_err = Process.CreatePipe+          }++  (exitcode, (mberr1, mberr2)) <- rawSystemProcAction verbosity cp $ \mb_in mb_out mb_err -> do+    let (inh, outh, errh) = (fromCreatePipe mb_in, fromCreatePipe mb_out, fromCreatePipe mb_err)+    flip Exception.finally (hClose inh >> hClose outh >> hClose errh) $ do+      -- output mode depends on what the caller wants+      -- but the errors are always assumed to be text (in the current locale)+      hSetBinaryMode errh False++      -- fork off a couple threads to pull on the stderr and stdout+      -- so if the process writes to stderr we do not block.++      withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do+        -- push all the input, if any+        ignoreSigPipe $ case input of+          Nothing -> hClose inh+          Just inputData -> IOData.hPutContents inh inputData++        -- wait for both to finish+        mberr1 <- waitCatch outA+        mberr2 <- waitCatch errA+        return (mberr1, mberr2)++  -- get the stderr, so it can be added to error message+  err <- reportOutputIOError mberr2++  unless (exitcode == ExitSuccess) $+    debug verbosity $+      path+        ++ " returned "+        ++ show exitcode+        ++ if null err+          then ""+          else+            " with error message:\n"+              ++ err+              ++ case input of+                Nothing -> ""+                Just d | IOData.null d -> ""+                Just (IODataText inp) -> "\nstdin input:\n" ++ inp+                Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp++  -- Check if we hit an exception while consuming the output+  -- (e.g. a text decoding error)+  out <- reportOutputIOError mberr1++  return (out, err, exitcode)+  where+    reportOutputIOError :: Either Exception.SomeException a -> IO a+    reportOutputIOError (Right x) = return x+    reportOutputIOError (Left exc) = case fromException exc of+      Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path))+      Nothing -> throwIO exc++-- | Ignore SIGPIPE in a subcomputation.+ignoreSigPipe :: IO () -> IO ()+ignoreSigPipe = Exception.handle $ \case+  GHC.IOError{GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe}+    | Errno ioe == ePIPE -> return ()+  e -> throwIO e++-- | Look for a program and try to find it's version number. It can accept+-- either an absolute path or the name of a program binary, in which case we+-- will look for the program on the path.+findProgramVersion+  :: String+  -- ^ version args+  -> (String -> String)+  -- ^ function to select version+  --   number from program output+  -> Verbosity+  -> FilePath+  -- ^ location+  -> IO (Maybe Version)+findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do+  str <-+    rawSystemStdout verbosity path [versionArg]+      `catchIO` (\_ -> return "")+      `catch` (\(_ :: VerboseException CabalException) -> return "")+      `catchExit` (\_ -> return "")+  let version :: Maybe Version+      version = simpleParsec (selectVersion str)+  case version of+    Nothing ->+      warn verbosity $+        "cannot determine version of "+          ++ path+          ++ " :\n"+          ++ show str+    Just v -> debug verbosity $ path ++ " is version " ++ prettyShow v+  return version++-- | Like the Unix xargs program. Useful for when we've got very long command+-- lines that might overflow an OS limit on command line length and so you+-- need to invoke a command multiple times to get all the args in.+--+-- Use it with either of the rawSystem variants above. For example:+--+-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs+xargs+  :: Int+  -> ([String] -> IO ())+  -> [String]+  -> [String]+  -> IO ()+xargs maxSize rawSystemFun fixedArgs bigArgs =+  let fixedArgSize = sum (map length fixedArgs) + length fixedArgs+      chunkSize = maxSize - fixedArgSize+   in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)+  where+    chunks len = unfoldr $ \s ->+      if null s+        then Nothing+        else Just (chunk [] len s)++    chunk acc _ [] = (reverse acc, [])+    chunk acc len (s : ss)+      | len' < len = chunk (s : acc) (len - len' - 1) ss+      | otherwise = (reverse acc, s : ss)+      where+        len' = length s++-- ------------------------------------------------------------++-- * File Utilities++-- ------------------------------------------------------------++----------------+-- Finding files++-- | Find a file by looking in a search path. The file path must match exactly.+--+-- @since 3.4.0.0+findFileCwd+  :: forall searchDir allowAbsolute+   . Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ working directory+  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+  -- ^ search directories+  -> RelativePath searchDir File+  -- ^ File Name+  -> IO (SymbolicPathX allowAbsolute Pkg File)+findFileCwd verbosity mbWorkDir searchPath fileName =+  findFirstFile+    (interpretSymbolicPath mbWorkDir)+    [ path </> fileName+    | path <- ordNub searchPath+    ]+    >>= maybe (dieWithException verbosity $ FindFile $ getSymbolicPath fileName) return++-- | Find a file by looking in a search path. The file path must match exactly.+findFileEx+  :: forall searchDir allowAbsolute+   . Verbosity+  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+  -- ^ search directories+  -> RelativePath searchDir File+  -- ^ File Name+  -> IO (SymbolicPathX allowAbsolute Pkg File)+findFileEx v = findFileCwd v Nothing++-- | Find a file by looking in a search path with one of a list of possible+-- file extensions. The file base name should be given and it will be tried+-- with each of the extensions in each element of the search path.+findFileWithExtension+  :: [Suffix]+  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+  -> RelativePath searchDir File+  -> IO (Maybe (SymbolicPathX allowAbsolute Pkg File))+findFileWithExtension =+  findFileCwdWithExtension Nothing++-- | Find a file by looking in a search path with one of a list of possible+-- file extensions.+--+-- @since 3.4.0.0+findFileCwdWithExtension+  :: forall searchDir allowAbsolute+   . Maybe (SymbolicPath CWD (Dir Pkg))+  -> [Suffix]+  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+  -> RelativePath searchDir File+  -> IO (Maybe (SymbolicPathX allowAbsolute Pkg File))+findFileCwdWithExtension cwd extensions searchPath baseName =+  fmap (uncurry (</>))+    <$> findFileCwdWithExtension' cwd extensions searchPath baseName++-- | @since 3.4.0.0+findAllFilesCwdWithExtension+  :: forall searchDir allowAbsolute+   . Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ working directory+  -> [Suffix]+  -- ^ extensions+  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+  -- ^ relative search locations+  -> RelativePath searchDir File+  -- ^ basename+  -> IO [SymbolicPathX allowAbsolute Pkg File]+findAllFilesCwdWithExtension mbWorkDir extensions searchPath basename =+  findAllFiles+    (interpretSymbolicPath mbWorkDir)+    [ path </> basename <.> ext+    | path <- ordNub searchPath+    , Suffix ext <- ordNub extensions+    ]++findAllFilesWithExtension+  :: [Suffix]+  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+  -> RelativePath searchDir File+  -> IO [SymbolicPathX allowAbsolute Pkg File]+findAllFilesWithExtension =+  findAllFilesCwdWithExtension Nothing++-- | Like 'findFileWithExtension' but returns which element of the search path+-- the file was found in, and the file path relative to that base directory.+findFileWithExtension'+  :: [Suffix]+  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+  -> RelativePath searchDir File+  -> IO (Maybe (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File))+findFileWithExtension' =+  findFileCwdWithExtension' Nothing++-- | Like 'findFileCwdWithExtension' but returns which element of the search path+-- the file was found in, and the file path relative to that base directory.+findFileCwdWithExtension'+  :: forall searchDir allowAbsolute+   . Maybe (SymbolicPath CWD (Dir Pkg))+  -> [Suffix]+  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+  -> RelativePath searchDir File+  -> IO (Maybe (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File))+findFileCwdWithExtension' cwd extensions searchPath baseName =+  findFirstFile+    (uncurry mkPath)+    [ (path, baseName <.> ext)+    | path <- ordNub searchPath+    , Suffix ext <- ordNub extensions+    ]+  where+    mkPath :: SymbolicPathX allowAbsolute Pkg (Dir searchDir) -> RelativePath searchDir File -> FilePath+    mkPath base file =+      interpretSymbolicPath cwd (base </> file)++findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a)+findFirstFile file = findFirst+  where+    findFirst [] = return Nothing+    findFirst (x : xs) = do+      exists <- doesFileExist (file x)+      if exists+        then return (Just x)+        else findFirst xs++findAllFiles :: (a -> FilePath) -> [a] -> IO [a]+findAllFiles file = filterM (doesFileExist . file)++-- | Finds the files corresponding to a list of Haskell module names.+--+-- As 'findModuleFile' but for a list of module names.+findModuleFilesEx+  :: forall searchDir allowAbsolute+   . Verbosity+  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+  -- ^ build prefix (location of objects)+  -> [Suffix]+  -- ^ search suffixes+  -> [ModuleName]+  -- ^ modules+  -> IO [(SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)]+findModuleFilesEx verbosity searchPath extensions moduleNames =+  traverse (findModuleFileEx verbosity searchPath extensions) moduleNames++-- | Finds the files corresponding to a list of Haskell module names.+--+-- As 'findModuleFileCwd' but for a list of module names.+findModuleFilesCwd+  :: forall searchDir allowAbsolute+   . Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+  -- ^ build prefix (location of objects)+  -> [Suffix]+  -- ^ search suffixes+  -> [ModuleName]+  -- ^ modules+  -> IO [(SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)]+findModuleFilesCwd verbosity cwd searchPath extensions moduleNames =+  traverse (findModuleFileCwd verbosity cwd searchPath extensions) moduleNames++-- | Find the file corresponding to a Haskell module name.+--+-- This is similar to 'findFileWithExtension'' but specialised to a module+-- name. The function fails if the file corresponding to the module is missing.+findModuleFileEx+  :: forall searchDir allowAbsolute+   . Verbosity+  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+  -- ^ build prefix (location of objects)+  -> [Suffix]+  -- ^ search suffixes+  -> ModuleName+  -- ^ module+  -> IO (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)+findModuleFileEx verbosity =+  findModuleFileCwd verbosity Nothing++-- | Find the file corresponding to a Haskell module name.+--+-- This is similar to 'findFileCwdWithExtension'' but specialised to a module+-- name. The function fails if the file corresponding to the module is missing.+findModuleFileCwd+  :: forall searchDir allowAbsolute+   . Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+  -- ^ build prefix (location of objects)+  -> [Suffix]+  -- ^ search suffixes+  -> ModuleName+  -- ^ module+  -> IO (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)+findModuleFileCwd verbosity cwd searchPath extensions mod_name = do+  mbRes <-+    findFileCwdWithExtension'+      cwd+      extensions+      searchPath+      (makeRelativePathEx $ ModuleName.toFilePath mod_name)+  case mbRes of+    Nothing ->+      dieWithException verbosity $+        FindModuleFileEx mod_name extensions (map getSymbolicPath searchPath)+    Just res -> return res++-- | List all the files in a directory and all subdirectories.+--+-- The order places files in sub-directories after all the files in their+-- parent directories. The list is generated lazily so is not well defined if+-- the source directory structure changes before the list is used.+getDirectoryContentsRecursive :: FilePath -> IO [FilePath]+getDirectoryContentsRecursive topdir = recurseDirectories [""]+  where+    recurseDirectories :: [FilePath] -> IO [FilePath]+    recurseDirectories [] = return []+    recurseDirectories (dir : dirs) = unsafeInterleaveIO $ do+      (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)+      files' <- recurseDirectories (dirs' ++ dirs)+      return (files ++ files')+      where+        collect files dirs' [] =+          return+            ( reverse files+            , reverse dirs'+            )+        collect files dirs' (entry : entries)+          | ignore entry =+              collect files dirs' entries+        collect files dirs' (entry : entries) = do+          let dirEntry = dir </> entry+          isDirectory <- doesDirectoryExist (topdir </> dirEntry)+          if isDirectory+            then collect files (dirEntry : dirs') entries+            else collect (dirEntry : files) dirs' entries++        ignore ['.'] = True+        ignore ['.', '.'] = True+        ignore _ = False++------------------------+-- Environment variables++-- | Is this directory in the system search path?+isInSearchPath :: FilePath -> IO Bool+isInSearchPath path = fmap (elem path) getSearchPath++addLibraryPath+  :: OS+  -> [FilePath]+  -> [(String, String)]+  -> [(String, String)]+addLibraryPath os paths = addEnv+  where+    pathsString = intercalate [searchPathSeparator] paths+    ldPath = case os of+      OSX -> "DYLD_LIBRARY_PATH"+      _ -> "LD_LIBRARY_PATH"++    addEnv [] = [(ldPath, pathsString)]+    addEnv ((key, value) : xs)+      | key == ldPath =+          if null value+            then (key, pathsString) : xs+            else (key, value ++ (searchPathSeparator : pathsString)) : xs+      | otherwise = (key, value) : addEnv xs++--------------------+-- Modification time++-- | Compare the modification times of two files to see if the first is newer+-- than the second. The first file must exist but the second need not.+-- The expected use case is when the second file is generated using the first.+-- In this use case, if the result is True then the second file is out of date.+moreRecentFile :: FilePath -> FilePath -> IO Bool+moreRecentFile a b = do+  exists <- doesFileExist b+  if not exists+    then return True+    else do+      tb <- getModificationTime b+      ta <- getModificationTime a+      return (ta > tb)++-- | Like 'moreRecentFile', but also checks that the first file exists.+existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool+existsAndIsMoreRecentThan a b = do+  exists <- doesFileExist a+  if not exists+    then return False+    else a `moreRecentFile` b++----------------------------------------+-- Copying and installing files and dirs++-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels.+createDirectoryIfMissingVerbose+  :: Verbosity+  -> Bool+  -- ^ Create its parents too?+  -> FilePath+  -> IO ()+createDirectoryIfMissingVerbose verbosity create_parents path0+  | create_parents = withFrozenCallStack $ createDirs (parents path0)+  | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0))+  where+    parents = reverse . scanl1 (</>) . splitDirectories . normalise++    createDirs [] = return ()+    createDirs (dir : []) = createDir dir throwIO+    createDirs (dir : dirs) =+      createDir dir $ \_ -> do+        createDirs dirs+        createDir dir throwIO++    createDir :: FilePath -> (IOException -> IO ()) -> IO ()+    createDir dir notExistHandler = do+      r <- tryIO $ createDirectoryVerbose verbosity dir+      case (r :: Either IOException ()) of+        Right () -> return ()+        Left e+          | isDoesNotExistError e -> notExistHandler e+          -- createDirectory (and indeed POSIX mkdir) does not distinguish+          -- between a dir already existing and a file already existing. So we+          -- check for it here. Unfortunately there is a slight race condition+          -- here, but we think it is benign. It could report an exception in+          -- the case that the dir did exist but another process deletes the+          -- directory and creates a file in its place before we can check+          -- that the directory did indeed exist.+          | isAlreadyExistsError e ->+              ( do+                  isDir <- doesDirectoryExist dir+                  unless isDir $ throwIO e+              )+                `catchIO` ((\_ -> return ()) :: IOException -> IO ())+          | otherwise -> throwIO e++createDirectoryVerbose :: Verbosity -> FilePath -> IO ()+createDirectoryVerbose verbosity dir = withFrozenCallStack $ do+  info verbosity $ "creating " ++ dir+  createDirectory dir+  setDirOrdinary dir++-- | Copies a file without copying file permissions. The target file is created+-- with default permissions. Any existing target file is replaced.+--+-- At higher verbosity levels it logs an info message.+copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO ()+copyFileVerbose verbosity src dest = withFrozenCallStack $ do+  info verbosity ("copy " ++ src ++ " to " ++ dest)+  copyFile src dest++-- | Install an ordinary file. This is like a file copy but the permissions+-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\"+-- while on Windows it uses the default permissions for the target directory.+installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO ()+installOrdinaryFile verbosity src dest = withFrozenCallStack $ do+  info verbosity ("Installing " ++ src ++ " to " ++ dest)+  copyOrdinaryFile src dest++-- | Install an executable file. This is like a file copy but the permissions+-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\"+-- while on Windows it uses the default permissions for the target directory.+installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()+installExecutableFile verbosity src dest = withFrozenCallStack $ do+  info verbosity ("Installing executable " ++ src ++ " to " ++ dest)+  copyExecutableFile src dest++-- | Install a file that may or not be executable, preserving permissions.+installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()+installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do+  perms <- getPermissions src+  if (executable perms) -- only checks user x bit+    then installExecutableFile verbosity src dest+    else installOrdinaryFile verbosity src dest++-- | Given a relative path to a file, copy it to the given directory, preserving+-- the relative path and creating the parent directories if needed.+copyFileTo+  :: Verbosity+  -> FilePath+  -> FilePath+  -> IO ()+copyFileTo verbosity dir file =+  withFrozenCallStack $+    copyFileToCwd+      verbosity+      Nothing+      (makeSymbolicPath dir)+      (makeRelativePathEx file)++-- | Given a relative path to a file, copy it to the given directory, preserving+-- the relative path and creating the parent directories if needed.+copyFileToCwd+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> SymbolicPath Pkg (Dir target)+  -> RelativePath Pkg File+  -> IO ()+copyFileToCwd verbosity mbWorkDir dir file = withFrozenCallStack $ do+  let targetFile = i $ dir </> unsafeCoerceSymbolicPath file+  createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)+  installOrdinaryFile verbosity (i file) targetFile+  where+    i :: SymbolicPathX allowAbs Pkg to -> FilePath+    i = interpretSymbolicPath mbWorkDir++-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',+-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.+copyFilesWith+  :: (Verbosity -> FilePath -> FilePath -> IO ())+  -> Verbosity+  -> FilePath+  -> [(FilePath, FilePath)]+  -> IO ()+copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do+  -- Create parent directories for everything+  let dirs = map (targetDir </>) . ordNub . map (takeDirectory . snd) $ srcFiles+  traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs++  -- Copy all the files+  sequence_+    [ let src = srcBase </> srcFile+          dest = targetDir </> srcFile+       in doCopy verbosity src dest+    | (srcBase, srcFile) <- srcFiles+    ]++-- | Copies a bunch of files to a target directory, preserving the directory+-- structure in the target location. The target directories are created if they+-- do not exist.+--+-- The files are identified by a pair of base directory and a path relative to+-- that base. It is only the relative part that is preserved in the+-- destination.+--+-- For example:+--+-- > copyFiles normal "dist/src"+-- >    [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")]+--+-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and+-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\".+--+-- This operation is not atomic. Any IO failure during the copy (including any+-- missing source files) leaves the target in an unknown state so it is best to+-- use it with a freshly created directory so that it can be simply deleted if+-- anything goes wrong.+copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()+copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs)++-- | This is like 'copyFiles' but uses 'installOrdinaryFile'.+installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()+installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs)++-- | This is like 'copyFiles' but uses 'installExecutableFile'.+installExecutableFiles+  :: Verbosity+  -> FilePath+  -> [(FilePath, FilePath)]+  -> IO ()+installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs)++-- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'.+installMaybeExecutableFiles+  :: Verbosity+  -> FilePath+  -> [(FilePath, FilePath)]+  -> IO ()+installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs)++-- | This installs all the files in a directory to a target location,+-- preserving the directory layout. All the files are assumed to be ordinary+-- rather than executable files.+installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO ()+installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do+  info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")+  srcFiles <- getDirectoryContentsRecursive srcDir+  installOrdinaryFiles verbosity destDir [(srcDir, f) | f <- srcFiles]++-- | Recursively copy the contents of one directory to another path.+copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO ()+copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do+  info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")+  srcFiles <- getDirectoryContentsRecursive srcDir+  copyFilesWith+    (const copyFile)+    verbosity+    destDir+    [ (srcDir, f)+    | f <- srcFiles+    ]++-------------------+-- File permissions++-- | Like 'doesFileExist', but also checks that the file is executable.+doesExecutableExist :: FilePath -> IO Bool+doesExecutableExist f = do+  exists <- doesFileExist f+  if exists+    then do+      perms <- getPermissions f+      return (executable perms)+    else return False++---------------------------+-- Temporary files and dirs++-- | Advanced options for 'withTempFile' and 'withTempDirectory'.+data TempFileOptions = TempFileOptions+  { optKeepTempFiles :: Bool+  -- ^ Keep temporary files?+  }++defaultTempFileOptions :: TempFileOptions+defaultTempFileOptions = TempFileOptions{optKeepTempFiles = False}++-- | Use a temporary filename that doesn't already exist+withTempFile+  :: String+  -- ^ File name template. See 'openTempFile'.+  -> (FilePath -> Handle -> IO a)+  -> IO a+withTempFile template f = withFrozenCallStack $+  withTempFileCwd template $+    \fp h -> f (getSymbolicPath fp) h++-- | Use a temporary filename that doesn't already exist.+withTempFileCwd+  :: String+  -- ^ File name template. See 'openTempFile'.+  -> (SymbolicPath Pkg File -> Handle -> IO a)+  -> IO a+withTempFileCwd = withFrozenCallStack $ withTempFileEx defaultTempFileOptions++-- | A version of 'withTempFile' that additionally takes a 'TempFileOptions'+-- argument.+withTempFileEx+  :: forall a+   . TempFileOptions+  -> String+  -- ^ File name template. See 'openTempFile'.+  -> (SymbolicPath Pkg File -> Handle -> IO a)+  -> IO a+withTempFileEx opts template action = do+  tmp <- getTemporaryDirectory+  withFrozenCallStack $+    Exception.bracket+      (openTempFile tmp template)+      ( \(name, handle) -> do+          hClose handle+          unless (optKeepTempFiles opts) $+            handleDoesNotExist () $+              removeFile $+                name+      )+      (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg tmp fn) h))+  where+    mkRelToPkg :: FilePath -> FilePath -> SymbolicPath Pkg File+    mkRelToPkg tmp fp =+      makeSymbolicPath tmp </> makeRelativePathEx (takeFileName fp)++-- 'openTempFile' returns a path of the form @i tmpDir </> fn@, but we+-- want 'withTempFileEx' to return @tmpDir </> fn@. So we split off+-- the filename and add back the (un-interpreted) directory.+-- This assumes 'openTempFile' returns a filepath of the form+-- @inputDir </> fn@, where @fn@ does not contain any path separators.++-- | Create and use a temporary directory.+--+-- Creates a new temporary directory inside the given directory, making use+-- of the template. The temp directory is deleted after use. For example:+--+-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ...+--+-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.+-- @src/sdist.342@.+withTempDirectory+  :: Verbosity+  -> FilePath+  -> String+  -> (FilePath -> IO a)+  -> IO a+withTempDirectory verb targetDir template f =+  withFrozenCallStack $+    withTempDirectoryCwd+      verb+      Nothing+      (makeSymbolicPath targetDir)+      template+      (f . getSymbolicPath)++-- | Create and use a temporary directory.+--+-- Creates a new temporary directory inside the given directory, making use+-- of the template. The temp directory is deleted after use. For example:+--+-- > withTempDirectory verbosity "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))+  -- ^ Working directory+  -> SymbolicPath Pkg (Dir tmpDir1)+  -> String+  -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a)+  -> IO a+withTempDirectoryCwd verbosity mbWorkDir targetDir template f =+  withFrozenCallStack $+    withTempDirectoryCwdEx+      verbosity+      defaultTempFileOptions+      mbWorkDir+      targetDir+      template+      (withLexicalCallStack (\x -> f x))++-- | A version of 'withTempDirectory' that additionally takes a+-- 'TempFileOptions' argument.+withTempDirectoryEx+  :: Verbosity+  -> TempFileOptions+  -> FilePath+  -> String+  -> (FilePath -> IO a)+  -> IO a+withTempDirectoryEx verbosity opts targetDir template f =+  withFrozenCallStack $+    withTempDirectoryCwdEx verbosity 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+  -> 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 =+  withFrozenCallStack $+    Exception.bracket+      (createTempDirectory (i targetDir) template)+      ( \tmpDirRelPath ->+          unless (optKeepTempFiles opts) $+            handleDoesNotExist () $+              removeDirectoryRecursive (i targetDir </> tmpDirRelPath)+      )+      (withLexicalCallStack (\tmpDirRelPath -> f $ targetDir </> makeRelativePathEx tmpDirRelPath))+  where+    i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path++-----------------------------------+-- Safely reading and writing files++-- | Write a file but only if it would have new content. If we would be writing+-- the same as the existing content then leave the file as is so that we do not+-- update the file's modification time.+--+-- NB: Before Cabal-3.0 the file content was assumed to be+--     ASCII-representable. Since Cabal-3.0 the file is assumed to be+--     UTF-8 encoded.+rewriteFileEx :: Verbosity -> FilePath -> String -> IO ()+rewriteFileEx verbosity path =+  rewriteFileLBS verbosity path . toUTF8LBS++-- | Same as `rewriteFileEx` but for 'ByteString's.+rewriteFileLBS :: Verbosity -> FilePath -> BS.ByteString -> IO ()+rewriteFileLBS verbosity path newContent =+  flip catchIO mightNotExist $ do+    existingContent <- annotateIO verbosity $ BS.readFile path+    _ <- evaluate (BS.length existingContent)+    unless (existingContent == newContent) $+      annotateIO verbosity $+        writeFileAtomic path newContent+  where+    mightNotExist e+      | isDoesNotExistError e =+          annotateIO verbosity $ writeFileAtomic path newContent+      | otherwise =+          ioError e++shortRelativePath :: FilePath -> FilePath -> FilePath+shortRelativePath from to =+  case dropCommonPrefix (splitDirectories from) (splitDirectories to) of+    (stuff, path) -> joinPath (map (const "..") stuff ++ path)+  where+    dropCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a])+    dropCommonPrefix (x : xs) (y : ys)+      | x == y = dropCommonPrefix xs ys+    dropCommonPrefix xs ys = (xs, ys)++-- | Drop the extension if it's one of 'exeExtensions', or return the path+-- unchanged.+dropExeExtension :: FilePath -> FilePath+dropExeExtension filepath =+  -- System.FilePath's extension handling functions are horribly+  -- inconsistent, consider:+  --+  --     isExtensionOf "" "foo"  == False but+  --     isExtensionOf "" "foo." == True.+  --+  -- On the other hand stripExtension doesn't remove the empty extension:+  --+  --    stripExtension "" "foo." == Just "foo."+  --+  -- Since by "" in exeExtensions we mean 'no extension' anyways we can+  -- just always ignore it here.+  let exts = [ext | ext <- exeExtensions, ext /= ""]+   in fromMaybe filepath $ do+        ext <- find (`FilePath.isExtensionOf` filepath) exts+        ext `FilePath.stripExtension` filepath++-- | List of possible executable file extensions on the current build+-- platform.+exeExtensions :: [String]+exeExtensions = case (buildArch, buildOS) of+  -- Possible improvement: on Windows, read the list of extensions from the+  -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat;+  -- .cmd".+  --+  -- See also #10179.+  --+  -- Also we cannot actually run @.bat@ files as we do now, because of+  -- https://github.com/haskell/process/issues/140. If we detect one of those,+  -- we should record that the program is a script and run a @Process.shell@ instead+  -- of a @Process.proc@.+  (_, Windows) -> ["", "exe"]+  (_, Ghcjs) -> ["", "exe"]+  (Wasm32, _) -> ["", "wasm"]+  _ -> [""]++-- ------------------------------------------------------------++-- * Finding the description file++-- ------------------------------------------------------------++-- | Package description file (/pkgname/@.cabal@) in the current+-- working directory.+defaultPackageDescCwd :: Verbosity -> IO (RelativePath Pkg File)+defaultPackageDescCwd verbosity = tryFindPackageDesc verbosity Nothing++-- | Find a package description file in the given directory.  Looks for+--  @.cabal@ files.+findPackageDesc+  :: Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ package directory+  -> IO (Either CabalException (RelativePath Pkg File))+findPackageDesc mbPkgDir =+  do+    let pkgDir = maybe "." getSymbolicPath mbPkgDir+    files <- getDirectoryContents pkgDir+    -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal+    -- file we filter to exclude dirs and null base file names:+    cabalFiles <-+      filterM+        (doesFileExist . uncurry (</>))+        [ (pkgDir, file)+        | file <- files+        , let (name, ext) = splitExtension file+        , not (null name) && ext == ".cabal"+        ]+    case map snd cabalFiles of+      [] -> return (Left NoDesc)+      [cabalFile] -> return (Right $ makeRelativePathEx cabalFile)+      multiple -> return (Left $ MultiDesc multiple)++-- | Like 'findPackageDesc', but calls 'die' in case of error.+tryFindPackageDesc+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ directory in which to look+  -> IO (RelativePath Pkg File)+tryFindPackageDesc verbosity dir =+  either (dieWithException verbosity) return =<< findPackageDesc dir++-- | Find auxiliary package information in the given directory.+--  Looks for @.buildinfo@ files.+findHookedPackageDesc+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ Working directory+  -> SymbolicPath Pkg (Dir Build)+  -- ^ Directory to search+  -> IO (Maybe (SymbolicPath Pkg File))+  -- ^ /dir/@\/@/pkgname/@.buildinfo@, if present+findHookedPackageDesc verbosity mbWorkDir dir = do+  files <- getDirectoryContents $ interpretSymbolicPath mbWorkDir dir+  buildInfoFiles <-+    filterM+      (doesFileExist . interpretSymbolicPath mbWorkDir)+      [ dir </> makeRelativePathEx file+      | file <- files+      , let (name, ext) = splitExtension file+      , not (null name) && ext == buildInfoExt+      ]+  case buildInfoFiles of+    [] -> return Nothing+    [f] -> return (Just f)+    _ -> dieWithException verbosity $ MultipleFilesWithExtension buildInfoExt++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/Simple/Utils/Json.hs 
@@ -1,46 +0,0 @@--- | Utility json lib for Cabal--- TODO: Remove it again.-module Distribution.Simple.Utils.Json-    ( Json(..)-    , renderJson-    ) where--data Json = JsonArray [Json]-          | JsonBool !Bool-          | JsonNull-          | JsonNumber !Int-          | JsonObject [(String, Json)]-          | JsonString !String--renderJson :: Json -> ShowS-renderJson (JsonArray objs)   =-  surround "[" "]" $ intercalate "," $ map renderJson objs-renderJson (JsonBool True)    = showString "true"-renderJson (JsonBool False)   = showString "false"-renderJson  JsonNull          = showString "null"-renderJson (JsonNumber n)     = shows n-renderJson (JsonObject attrs) =-  surround "{" "}" $ intercalate "," $ map render attrs-  where-    render (k,v) = (surround "\"" "\"" $ showString' k) . showString ":" . renderJson v-renderJson (JsonString s)     = surround "\"" "\"" $ showString' s--surround :: String -> String -> ShowS -> ShowS-surround begin end middle = showString begin . middle . showString end--showString' :: String -> ShowS-showString' xs = showStringWorker xs-    where-        showStringWorker :: String -> ShowS-        showStringWorker ('\"':as) = showString "\\\"" . showStringWorker as-        showStringWorker ('\\':as) = showString "\\\\" . showStringWorker as-        showStringWorker ('\'':as) = showString "\\\'" . showStringWorker as-        showStringWorker (x:as) = showString [x] . showStringWorker as-        showStringWorker [] = showString ""--intercalate :: String -> [ShowS] -> ShowS-intercalate sep = go-  where-    go []     = id-    go [x]    = x-    go (x:xs) = x . showString' sep . go xs
− src/Distribution/System.hs 
@@ -1,275 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.System--- Copyright   :  Duncan Coutts 2007-2008------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Cabal often needs to do slightly different things on specific platforms. You--- probably know about the 'System.Info.os' however using that is very--- inconvenient because it is a string and different Haskell implementations--- do not agree on using the same strings for the same platforms! (In--- particular see the controversy over \"windows\" vs \"mingw32\"). So to make it--- more consistent and easy to use we have an 'OS' enumeration.----module Distribution.System (-  -- * Operating System-  OS(..),-  buildOS,--  -- * Machine Architecture-  Arch(..),-  buildArch,--  -- * Platform is a pair of arch and OS-  Platform(..),-  buildPlatform,-  platformFromTriple,--  -- * Internal-  knownOSs,-  knownArches,--  -- * Classification-  ClassificationStrictness (..),-  classifyOS,-  classifyArch,-  ) where--import Prelude ()-import Distribution.Compat.Prelude-import Control.Applicative (liftA2)--import qualified System.Info (os, arch)-import Distribution.Utils.Generic (lowercase)--import Distribution.Parsec-import Distribution.Pretty--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp---- | How strict to be when classifying strings into the 'OS' and 'Arch' enums.------ The reason we have multiple ways to do the classification is because there--- are two situations where we need to do it.------ For parsing OS and arch names in .cabal files we really want everyone to be--- referring to the same or arch by the same name. Variety is not a virtue--- in this case. We don't mind about case though.------ For the System.Info.os\/arch different Haskell implementations use different--- names for the same or\/arch. Also they tend to distinguish versions of an--- OS\/arch which we just don't care about.------ The 'Compat' classification allows us to recognise aliases that are already--- in common use but it allows us to distinguish them from the canonical name--- which enables us to warn about such deprecated aliases.----data ClassificationStrictness = Permissive | Compat | Strict---- --------------------------------------------------------------- * Operating System--- ---------------------------------------------------------------- | These are the known OS names: Linux, Windows, OSX---  ,FreeBSD, OpenBSD, NetBSD, DragonFly---  ,Solaris, AIX, HPUX, IRIX---  ,HaLVM ,Hurd ,IOS, Android,Ghcjs------ The following aliases can also be used:,---    * Windows aliases: mingw32, win32, cygwin32---    * OSX alias: darwin---    * Hurd alias: gnu---    * FreeBSD alias: kfreebsdgnu---    * Solaris alias: solaris2----data OS = Linux | Windows | OSX        -- tier 1 desktop OSs-        | FreeBSD | OpenBSD | NetBSD   -- other free Unix OSs-        | DragonFly-        | Solaris | AIX | HPUX | IRIX  -- ageing Unix OSs-        | HaLVM                        -- bare metal / VMs / hypervisors-        | Hurd                         -- GNU's microkernel-        | IOS  | Android               -- mobile OSs-        | Ghcjs-        | OtherOS String-  deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)--instance Binary OS-instance Structured OS-instance NFData OS where rnf = genericRnf--knownOSs :: [OS]-knownOSs = [Linux, Windows, OSX-           ,FreeBSD, OpenBSD, NetBSD, DragonFly-           ,Solaris, AIX, HPUX, IRIX-           ,HaLVM-           ,Hurd-           ,IOS, Android-           ,Ghcjs]--osAliases :: ClassificationStrictness -> OS -> [String]-osAliases Permissive Windows = ["mingw32", "win32", "cygwin32"]-osAliases Compat     Windows = ["mingw32", "win32"]-osAliases _          OSX     = ["darwin"]-osAliases _          Hurd    = ["gnu"]-osAliases Permissive FreeBSD = ["kfreebsdgnu"]-osAliases Compat     FreeBSD = ["kfreebsdgnu"]-osAliases Permissive Solaris = ["solaris2"]-osAliases Compat     Solaris = ["solaris2"]-osAliases Permissive Android = ["linux-android", "linux-androideabi", "linux-androideabihf"]-osAliases Compat     Android = ["linux-android"]-osAliases _          _       = []--instance Pretty OS where-  pretty (OtherOS name) = Disp.text name-  pretty other          = Disp.text (lowercase (show other))--instance Parsec OS where-  parsec = classifyOS Compat <$> parsecIdent----classifyOS :: ClassificationStrictness -> String -> OS-classifyOS strictness s =-  fromMaybe (OtherOS s) $ lookup (lowercase s) osMap-  where-    osMap = [ (name, os)-            | os <- knownOSs-            , name <- prettyShow os : osAliases strictness os ]--buildOS :: OS-buildOS = classifyOS Permissive System.Info.os---- --------------------------------------------------------------- * Machine Architecture--- ---------------------------------------------------------------- | These are the known Arches: I386, X86_64, PPC, PPC64, Sparc,--- Arm, AArch64, Mips, SH, IA64, S39, Alpha, Hppa, Rs6000, M68k,--- Vax, and JavaScript.------ The following aliases can also be used:---    * PPC alias: powerpc---    * PPC64 alias : powerpc64, powerpc64le---    * Sparc aliases: sparc64, sun4---    * Mips aliases: mipsel, mipseb---    * Arm aliases: armeb, armel---    * AArch64 aliases: arm64----data Arch = I386  | X86_64  | PPC  | PPC64 | Sparc-          | Arm   | AArch64 | Mips | SH-          | IA64  | S390-          | Alpha | Hppa    | Rs6000-          | M68k  | Vax-          | JavaScript-          | OtherArch String-  deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)--instance Binary Arch-instance Structured Arch-instance NFData Arch where rnf = genericRnf--knownArches :: [Arch]-knownArches = [I386, X86_64, PPC, PPC64, Sparc-              ,Arm, AArch64, Mips, SH-              ,IA64, S390-              ,Alpha, Hppa, Rs6000-              ,M68k, Vax-              ,JavaScript]--archAliases :: ClassificationStrictness -> Arch -> [String]-archAliases Strict _       = []-archAliases Compat _       = []-archAliases _      PPC     = ["powerpc"]-archAliases _      PPC64   = ["powerpc64", "powerpc64le"]-archAliases _      Sparc   = ["sparc64", "sun4"]-archAliases _      Mips    = ["mipsel", "mipseb"]-archAliases _      Arm     = ["armeb", "armel"]-archAliases _      AArch64 = ["arm64"]-archAliases _      _       = []--instance Pretty Arch where-  pretty (OtherArch name) = Disp.text name-  pretty other            = Disp.text (lowercase (show other))--instance Parsec Arch where-  parsec = classifyArch Strict <$> parsecIdent--classifyArch :: ClassificationStrictness -> String -> Arch-classifyArch strictness s =-  fromMaybe (OtherArch s) $ lookup (lowercase s) archMap-  where-    archMap = [ (name, arch)-              | arch <- knownArches-              , name <- prettyShow arch : archAliases strictness arch ]--buildArch :: Arch-buildArch = classifyArch Permissive System.Info.arch---- --------------------------------------------------------------- * Platform--- --------------------------------------------------------------data Platform = Platform Arch OS-  deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)--instance Binary Platform-instance Structured Platform-instance NFData Platform where rnf = genericRnf--instance Pretty Platform where-  pretty (Platform arch os) = pretty arch <<>> Disp.char '-' <<>> pretty os--instance Parsec Platform where-    -- TODO: there are ambigious platforms like: `arch-word-os`-    -- which could be parsed as-    --   * Platform "arch-word" "os"-    --   * Platform "arch" "word-os"-    -- We could support that preferring variants 'OtherOS' or 'OtherArch'-    ---    -- For now we split into arch and os parts on the first dash.-    parsec = do-        arch <- parsecDashlessArch-        _ <- P.char '-'-        os <- parsec-        return (Platform arch os)-      where-        parsecDashlessArch = classifyArch Strict <$> dashlessIdent--        dashlessIdent = liftA2 (:) firstChar rest-          where-            firstChar = P.satisfy isAlpha-            rest = P.munch (\c -> isAlphaNum c || c == '_')---- | The platform Cabal was compiled on. In most cases,--- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're--- targeting).-buildPlatform :: Platform-buildPlatform = Platform buildArch buildOS---- Utils:--parsecIdent :: CabalParsing m => m String-parsecIdent = (:) <$> firstChar <*> rest-  where-    firstChar = P.satisfy isAlpha-    rest      = P.munch (\c -> isAlphaNum c || c == '_' || c == '-')--platformFromTriple :: String -> Maybe Platform-platformFromTriple triple =-    either (const Nothing) Just $ explicitEitherParsec parseTriple triple-  where parseWord = P.munch1 (\c -> isAlphaNum c || c == '_')-        parseTriple = do-          arch <- fmap (classifyArch Permissive) parseWord-          _ <- P.char '-'-          _ <- parseWord -- Skip vendor-          _ <- P.char '-'-          os <- fmap (classifyOS Permissive) parsecIdent -- OS may have hyphens, like-                                               -- 'nto-qnx'-          return $ Platform arch os
src/Distribution/TestSuite.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.TestSuite -- Copyright   :  Thomas Tuegel 2010@@ -12,91 +13,97 @@ -- -- This module defines the detailed test suite interface which makes it -- possible to expose individual tests to Cabal or other test agents.- module Distribution.TestSuite-    ( TestInstance(..)-    , OptionDescr(..)-    , OptionType(..)-    , Test(..)-    , Options-    , Progress(..)-    , Result(..)-    , testGroup-    ) where+  ( TestInstance (..)+  , OptionDescr (..)+  , OptionType (..)+  , Test (..)+  , Options+  , Progress (..)+  , Result (..)+  , testGroup+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  data TestInstance = TestInstance-    { run       :: IO Progress      -- ^ Perform the test.-    , name      :: String           -- ^ A name for the test, unique within a-                                    -- test suite.-    , tags      :: [String]         -- ^ Users can select groups of tests by-                                    -- their tags.-    , options   :: [OptionDescr]    -- ^ Descriptions of the options recognized-                                    -- by this test.-    , setOption :: String -> String -> Either String TestInstance-        -- ^ Try to set the named option to the given value. Returns an error-        -- message if the option is not supported or the value could not be-        -- correctly parsed; otherwise, a 'TestInstance' with the option set to-        -- the given value is returned.-    }+  { run :: IO Progress+  -- ^ Perform the test.+  , name :: String+  -- ^ A name for the test, unique within a+  -- test suite.+  , tags :: [String]+  -- ^ Users can select groups of tests by+  -- their tags.+  , options :: [OptionDescr]+  -- ^ Descriptions of the options recognized+  -- by this test.+  , setOption :: String -> String -> Either String TestInstance+  -- ^ Try to set the named option to the given value. Returns an error+  -- message if the option is not supported or the value could not be+  -- correctly parsed; otherwise, a 'TestInstance' with the option set to+  -- the given value is returned.+  }  data OptionDescr = OptionDescr-    { optionName        :: String-    , optionDescription :: String       -- ^ A human-readable description of the-                                        -- option to guide the user setting it.-    , optionType        :: OptionType-    , optionDefault     :: Maybe String-    }+  { optionName :: String+  , optionDescription :: String+  -- ^ A human-readable description of the+  -- option to guide the user setting it.+  , optionType :: OptionType+  , optionDefault :: Maybe String+  }   deriving (Eq, Read, Show)  data OptionType-    = OptionFile-        { optionFileMustExist   :: Bool-        , optionFileIsDir       :: Bool-        , optionFileExtensions  :: [String]-        }-    | OptionString-        { optionStringMultiline :: Bool-        }-    | OptionNumber-        { optionNumberIsInt     :: Bool-        , optionNumberBounds    :: (Maybe String, Maybe String)-        }-    | OptionBool-    | OptionEnum [String]-    | OptionSet [String]-    | OptionRngSeed+  = OptionFile+      { optionFileMustExist :: Bool+      , optionFileIsDir :: Bool+      , optionFileExtensions :: [String]+      }+  | OptionString+      { optionStringMultiline :: Bool+      }+  | OptionNumber+      { optionNumberIsInt :: Bool+      , optionNumberBounds :: (Maybe String, Maybe String)+      }+  | OptionBool+  | OptionEnum [String]+  | OptionSet [String]+  | OptionRngSeed   deriving (Eq, Read, Show)  data Test-    = Test TestInstance-    | Group-        { groupName     :: String-        , concurrently  :: Bool-            -- ^ If true, then children of this group may be run in parallel.-            -- Note that this setting is not inherited by children. In-            -- particular, consider a group F with "concurrently = False" that-            -- has some children, including a group T with "concurrently =-            -- True". The children of group T may be run concurrently with each-            -- other, as long as none are run at the same time as any of the-            -- direct children of group F.-        , groupTests    :: [Test]-        }-    | ExtraOptions [OptionDescr] Test+  = Test TestInstance+  | Group+      { groupName :: String+      , concurrently :: Bool+      -- ^ If true, then children of this group may be run in parallel.+      -- Note that this setting is not inherited by children. In+      -- particular, consider a group F with "concurrently = False" that+      -- has some children, including a group T with "concurrently =+      -- True". The children of group T may be run concurrently with each+      -- other, as long as none are run at the same time as any of the+      -- direct children of group F.+      , groupTests :: [Test]+      }+  | ExtraOptions [OptionDescr] Test  type Options = [(String, String)] -data Progress = Finished Result-              | Progress String (IO Progress)+data Progress+  = Finished Result+  | Progress String (IO Progress) -data Result = Pass-            | Fail String-            | Error String+data Result+  = Pass+  | Fail String+  | Error String   deriving (Eq, Read, Show)  -- | Create a named group of tests, which are assumed to be safe to run in -- parallel. testGroup :: String -> [Test] -> Test-testGroup n ts = Group { groupName = n, concurrently = True, groupTests = ts }+testGroup n ts = Group{groupName = n, concurrently = True, groupTests = ts}
− src/Distribution/Text.hs 
@@ -1,12 +0,0 @@--- Since @3.0@ this is a compat module.-module Distribution.Text (display, simpleParse) where-{- {-# DEPRECATED "Use Distribution.Parsec or Distribution.Pretty" #-} -}--import Distribution.Pretty-import Distribution.Parsec--display :: Pretty a => a -> String-display = prettyShow--simpleParse :: Parsec a => String -> Maybe a-simpleParse = simpleParsec
− src/Distribution/Types/AbiDependency.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Types.AbiDependency where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty--import qualified Distribution.Compat.CharParsing as P-import qualified Distribution.Package            as Package-import qualified Text.PrettyPrint                as Disp---- | An ABI dependency is a dependency on a library which also--- records the ABI hash ('abiHash') of the library it depends--- on.------ The primary utility of this is to enable an extra sanity when--- GHC loads libraries: it can check if the dependency has a matching--- ABI and if not, refuse to load this library.  This information--- is critical if we are shadowing libraries; differences in the--- ABI hash let us know what packages get shadowed by the new version--- of a package.-data AbiDependency = AbiDependency {-        depUnitId  :: Package.UnitId,-        depAbiHash :: Package.AbiHash-    }-  deriving (Eq, Generic, Read, Show, Typeable)--instance Pretty AbiDependency where-    pretty (AbiDependency uid abi) =-        pretty uid <<>> Disp.char '=' <<>> pretty abi--instance  Parsec AbiDependency where-    parsec = do-        uid <- parsec-        _ <- P.char '='-        abi <- parsec-        return (AbiDependency uid abi)--instance Binary AbiDependency-instance Structured AbiDependency-instance NFData AbiDependency where rnf = genericRnf
− src/Distribution/Types/AbiHash.hs 
@@ -1,61 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Distribution.Types.AbiHash-  ( AbiHash, unAbiHash, mkAbiHash-  ) where--import Prelude ()-import Distribution.Compat.Prelude-import Distribution.Utils.ShortText--import qualified Distribution.Compat.CharParsing as P-import Distribution.Pretty-import Distribution.Parsec--import Text.PrettyPrint (text)---- | ABI Hashes------ Use 'mkAbiHash' and 'unAbiHash' to convert from/to a--- 'String'.------ This type is opaque since @Cabal-2.0@------ @since 2.0.0.2-newtype AbiHash = AbiHash ShortText-    deriving (Eq, Show, Read, Generic, Typeable)---- | Construct a 'AbiHash' from a 'String'------ 'mkAbiHash' is the inverse to 'unAbiHash'------ Note: No validations are performed to ensure that the resulting--- 'AbiHash' is valid------ @since 2.0.0.2-unAbiHash :: AbiHash -> String-unAbiHash (AbiHash h) = fromShortText h---- | Convert 'AbiHash' to 'String'------ @since 2.0.0.2-mkAbiHash :: String -> AbiHash-mkAbiHash = AbiHash . toShortText---- | 'mkAbiHash'------ @since 2.0.0.2-instance IsString AbiHash where-    fromString = mkAbiHash--instance Binary AbiHash-instance Structured AbiHash-instance NFData AbiHash where rnf = genericRnf--instance Pretty AbiHash where-    pretty = text . unAbiHash--instance Parsec AbiHash where-    parsec = fmap mkAbiHash (P.munch isAlphaNum)
src/Distribution/Types/AnnotatedId.hs view
@@ -1,9 +1,11 @@-module Distribution.Types.AnnotatedId (-    AnnotatedId(..)-) where+{-# LANGUAGE DeriveFunctor #-} -import Prelude ()+module Distribution.Types.AnnotatedId+  ( AnnotatedId (..)+  ) where+ import Distribution.Compat.Prelude+import Prelude ()  import Distribution.Package import Distribution.Types.ComponentName@@ -14,21 +16,18 @@ -- -- Invariant: if ann_id x == ann_id y, then ann_pid x == ann_pid y -- and ann_cname x == ann_cname y-data AnnotatedId id = AnnotatedId {-        ann_pid   :: PackageId,-        ann_cname :: ComponentName,-        ann_id    :: id-    }-    deriving (Show)+data AnnotatedId id = AnnotatedId+  { ann_pid :: PackageId+  , ann_cname :: ComponentName+  , ann_id :: id+  }+  deriving (Show, Functor)  instance Eq id => Eq (AnnotatedId id) where-    x == y = ann_id x == ann_id y+  x == y = ann_id x == ann_id y  instance Ord id => Ord (AnnotatedId id) where-    compare x y = compare (ann_id x) (ann_id y)+  compare x y = compare (ann_id x) (ann_id y)  instance Package (AnnotatedId id) where-    packageId = ann_pid--instance Functor AnnotatedId where-    fmap f (AnnotatedId pid cn x) = AnnotatedId pid cn (f x)+  packageId = ann_pid
− src/Distribution/Types/Benchmark.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Distribution.Types.Benchmark (-    Benchmark(..),-    emptyBenchmark,-    benchmarkType,-    benchmarkModules,-    benchmarkModulesAutogen-) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Types.BuildInfo-import Distribution.Types.BenchmarkType-import Distribution.Types.BenchmarkInterface-import Distribution.Types.UnqualComponentName--import Distribution.ModuleName--import qualified Distribution.Types.BuildInfo.Lens as L---- | A \"benchmark\" stanza in a cabal file.----data Benchmark = Benchmark {-        benchmarkName      :: UnqualComponentName,-        benchmarkInterface :: BenchmarkInterface,-        benchmarkBuildInfo :: BuildInfo-    }-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary Benchmark-instance Structured Benchmark-instance NFData Benchmark where rnf = genericRnf--instance L.HasBuildInfo Benchmark where-    buildInfo f (Benchmark x1 x2 x3) = fmap (\y1 -> Benchmark x1 x2 y1) (f x3)--instance Monoid Benchmark where-    mempty = Benchmark {-        benchmarkName      = mempty,-        benchmarkInterface = mempty,-        benchmarkBuildInfo = mempty-    }-    mappend = (<>)--instance Semigroup Benchmark where-    a <> b = Benchmark {-        benchmarkName      = combine' benchmarkName,-        benchmarkInterface = combine  benchmarkInterface,-        benchmarkBuildInfo = combine  benchmarkBuildInfo-    }-        where combine  field = field a `mappend` field b-              combine' field = case ( unUnqualComponentName $ field a-                                    , unUnqualComponentName $ field b) of-                        ("", _) -> field b-                        (_, "") -> field a-                        (x, y) -> error $ "Ambiguous values for test field: '"-                            ++ x ++ "' and '" ++ y ++ "'"--emptyBenchmark :: Benchmark-emptyBenchmark = mempty--benchmarkType :: Benchmark -> BenchmarkType-benchmarkType benchmark = case benchmarkInterface benchmark of-  BenchmarkExeV10 ver _              -> BenchmarkTypeExe ver-  BenchmarkUnsupported benchmarktype -> benchmarktype---- | Get all the module names from a benchmark.-benchmarkModules :: Benchmark -> [ModuleName]-benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark)---- | Get all the auto generated module names from a benchmark.--- This are a subset of 'benchmarkModules'.-benchmarkModulesAutogen :: Benchmark -> [ModuleName]-benchmarkModulesAutogen benchmark = autogenModules (benchmarkBuildInfo benchmark)
− src/Distribution/Types/Benchmark/Lens.hs 
@@ -1,27 +0,0 @@-module Distribution.Types.Benchmark.Lens (-    Benchmark,-    module Distribution.Types.Benchmark.Lens,-    ) where--import Distribution.Compat.Lens-import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Types.Benchmark           (Benchmark)-import Distribution.Types.BenchmarkInterface  (BenchmarkInterface)-import Distribution.Types.BuildInfo           (BuildInfo)-import Distribution.Types.UnqualComponentName (UnqualComponentName)--import qualified Distribution.Types.Benchmark as T--benchmarkName :: Lens' Benchmark UnqualComponentName-benchmarkName f s = fmap (\x -> s { T.benchmarkName = x }) (f (T.benchmarkName s))-{-# INLINE benchmarkName #-}--benchmarkInterface :: Lens' Benchmark BenchmarkInterface-benchmarkInterface f s = fmap (\x -> s { T.benchmarkInterface = x }) (f (T.benchmarkInterface s))-{-# INLINE benchmarkInterface #-}--benchmarkBuildInfo :: Lens' Benchmark BuildInfo-benchmarkBuildInfo f s = fmap (\x -> s { T.benchmarkBuildInfo = x }) (f (T.benchmarkBuildInfo s))-{-# INLINE benchmarkBuildInfo #-}
− src/Distribution/Types/BenchmarkInterface.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Distribution.Types.BenchmarkInterface (-    BenchmarkInterface(..),-) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Types.BenchmarkType-import Distribution.Version---- | The benchmark interfaces that are currently defined. Each--- benchmark must specify which interface it supports.------ More interfaces may be defined in future, either new revisions or--- totally new interfaces.----data BenchmarkInterface =--     -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark-     -- takes the form of an executable. It returns a zero exit code-     -- for success, non-zero for failure. The stdout and stderr-     -- channels may be logged. It takes no command line parameters-     -- and nothing on stdin.-     ---     BenchmarkExeV10 Version FilePath--     -- | A benchmark that does not conform to one of the above-     -- interfaces for the given reason (e.g. unknown benchmark type).-     ---   | BenchmarkUnsupported BenchmarkType-   deriving (Eq, Generic, Read, Show, Typeable, Data)--instance Binary BenchmarkInterface-instance Structured BenchmarkInterface-instance NFData BenchmarkInterface where rnf = genericRnf--instance Monoid BenchmarkInterface where-    mempty  =  BenchmarkUnsupported (BenchmarkTypeUnknown mempty nullVersion)-    mappend = (<>)--instance Semigroup BenchmarkInterface where-    a <> (BenchmarkUnsupported _) = a-    _ <> b                        = b
− src/Distribution/Types/BenchmarkType.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE OverloadedStrings  #-}--module Distribution.Types.BenchmarkType (-    BenchmarkType(..),-    knownBenchmarkTypes,-) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty-import Distribution.Version-import Text.PrettyPrint     (char, text)---- | The \"benchmark-type\" field in the benchmark stanza.----data BenchmarkType = BenchmarkTypeExe Version-                     -- ^ \"type: exitcode-stdio-x.y\"-                   | BenchmarkTypeUnknown String Version-                     -- ^ Some unknown benchmark type e.g. \"type: foo\"-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary BenchmarkType-instance Structured BenchmarkType-instance NFData BenchmarkType where rnf = genericRnf--knownBenchmarkTypes :: [BenchmarkType]-knownBenchmarkTypes = [ BenchmarkTypeExe (mkVersion [1,0]) ]--instance Pretty BenchmarkType where-  pretty (BenchmarkTypeExe ver)          = text "exitcode-stdio-" <<>> pretty ver-  pretty (BenchmarkTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver--instance Parsec BenchmarkType where-    parsec = parsecStandard $ \ver name -> case name of-       "exitcode-stdio" -> BenchmarkTypeExe ver-       _                -> BenchmarkTypeUnknown name ver
− src/Distribution/Types/BuildInfo.hs 
@@ -1,266 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Distribution.Types.BuildInfo (-    BuildInfo(..),--    emptyBuildInfo,-    allLanguages,-    allExtensions,-    usedExtensions,-    usesTemplateHaskellOrQQ,--    hcOptions,-    hcProfOptions,-    hcSharedOptions,-    hcStaticOptions,-) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Types.Mixin-import Distribution.Types.Dependency-import Distribution.Types.ExeDependency-import Distribution.Types.LegacyExeDependency-import Distribution.Types.PkgconfigDependency-import Distribution.Utils.Path--import Distribution.ModuleName-import Distribution.Compiler-import Language.Haskell.Extension---- Consider refactoring into executable and library versions.-data BuildInfo = BuildInfo {-        -- | component is buildable here-        buildable         :: Bool,-        -- | Tools needed to build this bit.-        ---        -- This is a legacy field that 'buildToolDepends' largely supersedes.-        ---        -- Unless use are very sure what you are doing, use the functions in-        -- "Distribution.Simple.BuildToolDepends" rather than accessing this-        -- field directly.-        buildTools        :: [LegacyExeDependency],-        -- | Haskell tools needed to build this bit-        ---        -- This field is better than 'buildTools' because it allows one to-        -- precisely specify an executable in a package.-        ---        -- Unless use are very sure what you are doing, use the functions in-        -- "Distribution.Simple.BuildToolDepends" rather than accessing this-        -- field directly.-        buildToolDepends  :: [ExeDependency],-        cppOptions        :: [String],  -- ^ options for pre-processing Haskell code-        asmOptions        :: [String],  -- ^ options for assmebler-        cmmOptions        :: [String],  -- ^ options for C-- compiler-        ccOptions         :: [String],  -- ^ options for C compiler-        cxxOptions        :: [String],  -- ^ options for C++ compiler-        ldOptions         :: [String],  -- ^ options for linker-        hsc2hsOptions     :: [String],  -- ^ options for hsc2hs-        pkgconfigDepends  :: [PkgconfigDependency], -- ^ pkg-config packages that are used-        frameworks        :: [String], -- ^support frameworks for Mac OS X-        extraFrameworkDirs:: [String], -- ^ extra locations to find frameworks.-        asmSources        :: [FilePath], -- ^ Assembly files.-        cmmSources        :: [FilePath], -- ^ C-- files.-        cSources          :: [FilePath],-        cxxSources        :: [FilePath],-        jsSources         :: [FilePath],-        hsSourceDirs      :: [SymbolicPath PackageDir SourceDir], -- ^ where to look for the Haskell module hierarchy-        otherModules      :: [ModuleName], -- ^ non-exposed or non-main modules-        virtualModules    :: [ModuleName], -- ^ exposed modules that do not have a source file (e.g. @GHC.Prim@ from @ghc-prim@ package)-        autogenModules    :: [ModuleName], -- ^ not present on sdist, Paths_* or user-generated with a custom Setup.hs--        defaultLanguage   :: Maybe Language,-- ^ language used when not explicitly specified-        otherLanguages    :: [Language],    -- ^ other languages used within the package-        defaultExtensions :: [Extension],   -- ^ language extensions used by all modules-        otherExtensions   :: [Extension],   -- ^ other language extensions used within the package-        oldExtensions     :: [Extension],   -- ^ the old extensions field, treated same as 'defaultExtensions'--        extraLibs         :: [String], -- ^ what libraries to link with when compiling a program that uses your package-        extraGHCiLibs     :: [String], -- ^ if present, overrides extraLibs when package is loaded with GHCi.-        extraBundledLibs  :: [String], -- ^ if present, adds libs to hs-libraries, which become part of the package.-                                       --   Example: the Cffi library shipping with the rts, alognside the HSrts-1.0.a,.o,...-                                       --   Example 2: a library that is being built by a foreing tool (e.g. rust)-                                       --              and copied and registered together with this library.  The-                                       --              logic on how this library is built will have to be encoded in a-                                       --              custom Setup for now.  Otherwise cabal would need to lear how to-                                       --              call arbitrary library builders.-        extraLibFlavours  :: [String], -- ^ Hidden Flag.  This set of strings, will be appended to all libraries when-                                       --   copying. E.g. [libHS<name>_<flavour> | flavour <- extraLibFlavours]. This-                                       --   should only be needed in very specific cases, e.g. the `rts` package, where-                                       --   there are multiple copies of slightly differently built libs.-        extraDynLibFlavours :: [String], -- ^ Hidden Flag. This set of strings will be appended to all /dynamic/-                                         --   libraries when copying. This is particularly useful with the `rts` package,-                                         --   where we want different dynamic flavours of the RTS library to be installed.-        extraLibDirs      :: [String],-        includeDirs       :: [FilePath], -- ^directories to find .h files-        includes          :: [FilePath], -- ^ The .h files to be found in includeDirs-        autogenIncludes   :: [FilePath], -- ^ The .h files to be generated (e.g. by @autoconf@)-        installIncludes   :: [FilePath], -- ^ .h files to install with the package-        options           :: PerCompilerFlavor [String],-        profOptions       :: PerCompilerFlavor [String],-        sharedOptions     :: PerCompilerFlavor [String],-        staticOptions     :: PerCompilerFlavor [String],-        customFieldsBI    :: [(String,String)], -- ^Custom fields starting-                                                -- with x-, stored in a-                                                -- simple assoc-list.-        targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target-        mixins :: [Mixin]-    }-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary BuildInfo-instance Structured BuildInfo-instance NFData BuildInfo where rnf = genericRnf--instance Monoid BuildInfo where-  mempty = BuildInfo {-    buildable           = True,-    buildTools          = [],-    buildToolDepends    = [],-    cppOptions          = [],-    asmOptions          = [],-    cmmOptions          = [],-    ccOptions           = [],-    cxxOptions          = [],-    ldOptions           = [],-    hsc2hsOptions       = [],-    pkgconfigDepends    = [],-    frameworks          = [],-    extraFrameworkDirs  = [],-    asmSources          = [],-    cmmSources          = [],-    cSources            = [],-    cxxSources          = [],-    jsSources           = [],-    hsSourceDirs        = [],-    otherModules        = [],-    virtualModules      = [],-    autogenModules      = [],-    defaultLanguage     = Nothing,-    otherLanguages      = [],-    defaultExtensions   = [],-    otherExtensions     = [],-    oldExtensions       = [],-    extraLibs           = [],-    extraGHCiLibs       = [],-    extraBundledLibs    = [],-    extraLibFlavours    = [],-    extraDynLibFlavours = [],-    extraLibDirs        = [],-    includeDirs         = [],-    includes            = [],-    autogenIncludes     = [],-    installIncludes     = [],-    options             = mempty,-    profOptions         = mempty,-    sharedOptions       = mempty,-    staticOptions       = mempty,-    customFieldsBI      = [],-    targetBuildDepends  = [],-    mixins              = []-  }-  mappend = (<>)--instance Semigroup BuildInfo where-  a <> b = BuildInfo {-    buildable           = buildable a && buildable b,-    buildTools          = combine    buildTools,-    buildToolDepends    = combine    buildToolDepends,-    cppOptions          = combine    cppOptions,-    asmOptions          = combine    asmOptions,-    cmmOptions          = combine    cmmOptions,-    ccOptions           = combine    ccOptions,-    cxxOptions          = combine    cxxOptions,-    ldOptions           = combine    ldOptions,-    hsc2hsOptions       = combine    hsc2hsOptions,-    pkgconfigDepends    = combine    pkgconfigDepends,-    frameworks          = combineNub frameworks,-    extraFrameworkDirs  = combineNub extraFrameworkDirs,-    asmSources          = combineNub asmSources,-    cmmSources          = combineNub cmmSources,-    cSources            = combineNub cSources,-    cxxSources          = combineNub cxxSources,-    jsSources           = combineNub jsSources,-    hsSourceDirs        = combineNub hsSourceDirs,-    otherModules        = combineNub otherModules,-    virtualModules      = combineNub virtualModules,-    autogenModules      = combineNub autogenModules,-    defaultLanguage     = combineMby defaultLanguage,-    otherLanguages      = combineNub otherLanguages,-    defaultExtensions   = combineNub defaultExtensions,-    otherExtensions     = combineNub otherExtensions,-    oldExtensions       = combineNub oldExtensions,-    extraLibs           = combine    extraLibs,-    extraGHCiLibs       = combine    extraGHCiLibs,-    extraBundledLibs    = combine    extraBundledLibs,-    extraLibFlavours    = combine    extraLibFlavours,-    extraDynLibFlavours = combine    extraDynLibFlavours,-    extraLibDirs        = combineNub extraLibDirs,-    includeDirs         = combineNub includeDirs,-    includes            = combineNub includes,-    autogenIncludes     = combineNub autogenIncludes,-    installIncludes     = combineNub installIncludes,-    options             = combine    options,-    profOptions         = combine    profOptions,-    sharedOptions       = combine    sharedOptions,-    staticOptions       = combine    staticOptions,-    customFieldsBI      = combine    customFieldsBI,-    targetBuildDepends  = combineNub targetBuildDepends,-    mixins              = combine    mixins-  }-    where-      combine    field = field a `mappend` field b-      combineNub field = nub (combine field)-      combineMby field = field b `mplus` field a--emptyBuildInfo :: BuildInfo-emptyBuildInfo = mempty---- | The 'Language's used by this component----allLanguages :: BuildInfo -> [Language]-allLanguages bi = maybeToList (defaultLanguage bi)-               ++ otherLanguages bi---- | The 'Extension's that are used somewhere by this component----allExtensions :: BuildInfo -> [Extension]-allExtensions bi = usedExtensions bi-                ++ otherExtensions bi---- | The 'Extensions' that are used by all modules in this component----usedExtensions :: BuildInfo -> [Extension]-usedExtensions bi = oldExtensions bi-                 ++ defaultExtensions bi---- | Whether any modules in this component use Template Haskell or--- Quasi Quotes-usesTemplateHaskellOrQQ :: BuildInfo -> Bool-usesTemplateHaskellOrQQ bi = any p (allExtensions bi)-  where-    p ex = ex `elem`-      [EnableExtension TemplateHaskell, EnableExtension QuasiQuotes]---- |Select options for a particular Haskell compiler.-hcOptions :: CompilerFlavor -> BuildInfo -> [String]-hcOptions = lookupHcOptions options--hcProfOptions :: CompilerFlavor -> BuildInfo -> [String]-hcProfOptions = lookupHcOptions profOptions--hcSharedOptions :: CompilerFlavor -> BuildInfo -> [String]-hcSharedOptions = lookupHcOptions sharedOptions--hcStaticOptions :: CompilerFlavor -> BuildInfo -> [String]-hcStaticOptions = lookupHcOptions staticOptions--lookupHcOptions :: (BuildInfo -> PerCompilerFlavor [String])-                -> CompilerFlavor -> BuildInfo -> [String]-lookupHcOptions f hc bi = case f bi of-    PerCompilerFlavor ghc ghcjs-        | hc == GHC   -> ghc-        | hc == GHCJS -> ghcjs-        | otherwise   -> mempty
− src/Distribution/Types/BuildInfo/Lens.hs 
@@ -1,342 +0,0 @@-module Distribution.Types.BuildInfo.Lens (-    BuildInfo,-    HasBuildInfo (..),-    HasBuildInfos (..),-    ) where--import Distribution.Compat.Lens-import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Compiler                  (PerCompilerFlavor)-import Distribution.ModuleName                (ModuleName)-import Distribution.Types.BuildInfo           (BuildInfo)-import Distribution.Types.Dependency          (Dependency)-import Distribution.Types.ExeDependency       (ExeDependency)-import Distribution.Types.LegacyExeDependency (LegacyExeDependency)-import Distribution.Types.Mixin               (Mixin)-import Distribution.Types.PkgconfigDependency (PkgconfigDependency)-import Distribution.Utils.Path-import Language.Haskell.Extension             (Extension, Language)--import qualified Distribution.Types.BuildInfo as T---- | Classy lenses for 'BuildInfo'.-class HasBuildInfo a where-   buildInfo :: Lens' a BuildInfo--   buildable :: Lens' a Bool-   buildable = buildInfo . buildable-   {-# INLINE buildable #-}--   buildTools :: Lens' a [LegacyExeDependency]-   buildTools = buildInfo . buildTools-   {-# INLINE buildTools #-}--   buildToolDepends :: Lens' a [ExeDependency]-   buildToolDepends = buildInfo . buildToolDepends-   {-# INLINE buildToolDepends #-}--   cppOptions :: Lens' a [String]-   cppOptions = buildInfo . cppOptions-   {-# INLINE cppOptions #-}--   asmOptions :: Lens' a [String]-   asmOptions = buildInfo . asmOptions-   {-# INLINE asmOptions #-}--   cmmOptions :: Lens' a [String]-   cmmOptions = buildInfo . cmmOptions-   {-# INLINE cmmOptions #-}--   ccOptions :: Lens' a [String]-   ccOptions = buildInfo . ccOptions-   {-# INLINE ccOptions #-}--   cxxOptions :: Lens' a [String]-   cxxOptions = buildInfo . cxxOptions-   {-# INLINE cxxOptions #-}--   ldOptions :: Lens' a [String]-   ldOptions = buildInfo . ldOptions-   {-# INLINE ldOptions #-}--   hsc2hsOptions :: Lens' a [String]-   hsc2hsOptions = buildInfo . hsc2hsOptions-   {-# INLINE hsc2hsOptions #-}--   pkgconfigDepends :: Lens' a [PkgconfigDependency]-   pkgconfigDepends = buildInfo . pkgconfigDepends-   {-# INLINE pkgconfigDepends #-}--   frameworks :: Lens' a [String]-   frameworks = buildInfo . frameworks-   {-# INLINE frameworks #-}--   extraFrameworkDirs :: Lens' a [String]-   extraFrameworkDirs = buildInfo . extraFrameworkDirs-   {-# INLINE extraFrameworkDirs #-}--   asmSources :: Lens' a [FilePath]-   asmSources = buildInfo . asmSources-   {-# INLINE asmSources #-}--   cmmSources :: Lens' a [FilePath]-   cmmSources = buildInfo . cmmSources-   {-# INLINE cmmSources #-}--   cSources :: Lens' a [FilePath]-   cSources = buildInfo . cSources-   {-# INLINE cSources #-}--   cxxSources :: Lens' a [FilePath]-   cxxSources = buildInfo . cxxSources-   {-# INLINE cxxSources #-}--   jsSources :: Lens' a [FilePath]-   jsSources = buildInfo . jsSources-   {-# INLINE jsSources #-}--   hsSourceDirs :: Lens' a [SymbolicPath PackageDir SourceDir]-   hsSourceDirs = buildInfo . hsSourceDirs-   {-# INLINE hsSourceDirs #-}--   otherModules :: Lens' a [ModuleName]-   otherModules = buildInfo . otherModules-   {-# INLINE otherModules #-}--   virtualModules :: Lens' a [ModuleName]-   virtualModules = buildInfo . virtualModules-   {-# INLINE virtualModules #-}--   autogenModules :: Lens' a [ModuleName]-   autogenModules = buildInfo . autogenModules-   {-# INLINE autogenModules #-}--   defaultLanguage :: Lens' a (Maybe Language)-   defaultLanguage = buildInfo . defaultLanguage-   {-# INLINE defaultLanguage #-}--   otherLanguages :: Lens' a [Language]-   otherLanguages = buildInfo . otherLanguages-   {-# INLINE otherLanguages #-}--   defaultExtensions :: Lens' a [Extension]-   defaultExtensions = buildInfo . defaultExtensions-   {-# INLINE defaultExtensions #-}--   otherExtensions :: Lens' a [Extension]-   otherExtensions = buildInfo . otherExtensions-   {-# INLINE otherExtensions #-}--   oldExtensions :: Lens' a [Extension]-   oldExtensions = buildInfo . oldExtensions-   {-# INLINE oldExtensions #-}--   extraLibs :: Lens' a [String]-   extraLibs = buildInfo . extraLibs-   {-# INLINE extraLibs #-}--   extraGHCiLibs :: Lens' a [String]-   extraGHCiLibs = buildInfo . extraGHCiLibs-   {-# INLINE extraGHCiLibs #-}--   extraBundledLibs :: Lens' a [String]-   extraBundledLibs = buildInfo . extraBundledLibs-   {-# INLINE extraBundledLibs #-}--   extraLibFlavours :: Lens' a [String]-   extraLibFlavours = buildInfo . extraLibFlavours-   {-# INLINE extraLibFlavours #-}--   extraDynLibFlavours :: Lens' a [String]-   extraDynLibFlavours = buildInfo . extraDynLibFlavours-   {-# INLINE extraDynLibFlavours #-}--   extraLibDirs :: Lens' a [String]-   extraLibDirs = buildInfo . extraLibDirs-   {-# INLINE extraLibDirs #-}--   includeDirs :: Lens' a [FilePath]-   includeDirs = buildInfo . includeDirs-   {-# INLINE includeDirs #-}--   includes :: Lens' a [FilePath]-   includes = buildInfo . includes-   {-# INLINE includes #-}--   autogenIncludes :: Lens' a [FilePath]-   autogenIncludes = buildInfo . autogenIncludes-   {-# INLINE autogenIncludes #-}--   installIncludes :: Lens' a [FilePath]-   installIncludes = buildInfo . installIncludes-   {-# INLINE installIncludes #-}--   options :: Lens' a (PerCompilerFlavor [String])-   options = buildInfo . options-   {-# INLINE options #-}--   profOptions :: Lens' a (PerCompilerFlavor [String])-   profOptions = buildInfo . profOptions-   {-# INLINE profOptions #-}--   sharedOptions :: Lens' a (PerCompilerFlavor [String])-   sharedOptions = buildInfo . sharedOptions-   {-# INLINE sharedOptions #-}--   staticOptions :: Lens' a (PerCompilerFlavor [String])-   staticOptions = buildInfo . staticOptions-   {-# INLINE staticOptions #-}--   customFieldsBI :: Lens' a [(String,String)]-   customFieldsBI = buildInfo . customFieldsBI-   {-# INLINE customFieldsBI #-}--   targetBuildDepends :: Lens' a [Dependency]-   targetBuildDepends = buildInfo . targetBuildDepends-   {-# INLINE targetBuildDepends #-}--   mixins :: Lens' a [Mixin]-   mixins = buildInfo . mixins-   {-# INLINE mixins #-}---instance HasBuildInfo BuildInfo where-    buildInfo = id-    {-# INLINE buildInfo #-}--    buildable f s = fmap (\x -> s { T.buildable = x }) (f (T.buildable s))-    {-# INLINE buildable #-}--    buildTools f s = fmap (\x -> s { T.buildTools = x }) (f (T.buildTools s))-    {-# INLINE buildTools #-}--    buildToolDepends f s = fmap (\x -> s { T.buildToolDepends = x }) (f (T.buildToolDepends s))-    {-# INLINE buildToolDepends #-}--    cppOptions f s = fmap (\x -> s { T.cppOptions = x }) (f (T.cppOptions s))-    {-# INLINE cppOptions #-}--    asmOptions f s = fmap (\x -> s { T.asmOptions = x }) (f (T.asmOptions s))-    {-# INLINE asmOptions #-}--    cmmOptions f s = fmap (\x -> s { T.cmmOptions = x }) (f (T.cmmOptions s))-    {-# INLINE cmmOptions #-}--    ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s))-    {-# INLINE ccOptions #-}--    cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s))-    {-# INLINE cxxOptions #-}--    ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s))-    {-# INLINE ldOptions #-}--    hsc2hsOptions f s = fmap (\x -> s { T.hsc2hsOptions = x }) (f (T.hsc2hsOptions s))-    {-# INLINE hsc2hsOptions #-}--    pkgconfigDepends f s = fmap (\x -> s { T.pkgconfigDepends = x }) (f (T.pkgconfigDepends s))-    {-# INLINE pkgconfigDepends #-}--    frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s))-    {-# INLINE frameworks #-}--    extraFrameworkDirs f s = fmap (\x -> s { T.extraFrameworkDirs = x }) (f (T.extraFrameworkDirs s))-    {-# INLINE extraFrameworkDirs #-}--    asmSources f s = fmap (\x -> s { T.asmSources = x }) (f (T.asmSources s))-    {-# INLINE asmSources #-}--    cmmSources f s = fmap (\x -> s { T.cmmSources = x }) (f (T.cmmSources s))-    {-# INLINE cmmSources #-}--    cSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cSources s))-    {-# INLINE cSources #-}--    cxxSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cxxSources s))-    {-# INLINE cxxSources #-}--    jsSources f s = fmap (\x -> s { T.jsSources = x }) (f (T.jsSources s))-    {-# INLINE jsSources #-}--    hsSourceDirs f s = fmap (\x -> s { T.hsSourceDirs = x }) (f (T.hsSourceDirs s))-    {-# INLINE hsSourceDirs #-}--    otherModules f s = fmap (\x -> s { T.otherModules = x }) (f (T.otherModules s))-    {-# INLINE otherModules #-}--    virtualModules f s = fmap (\x -> s { T.virtualModules = x }) (f (T.virtualModules s))-    {-# INLINE virtualModules #-}--    autogenModules f s = fmap (\x -> s { T.autogenModules = x }) (f (T.autogenModules s))-    {-# INLINE autogenModules #-}--    defaultLanguage f s = fmap (\x -> s { T.defaultLanguage = x }) (f (T.defaultLanguage s))-    {-# INLINE defaultLanguage #-}--    otherLanguages f s = fmap (\x -> s { T.otherLanguages = x }) (f (T.otherLanguages s))-    {-# INLINE otherLanguages #-}--    defaultExtensions f s = fmap (\x -> s { T.defaultExtensions = x }) (f (T.defaultExtensions s))-    {-# INLINE defaultExtensions #-}--    otherExtensions f s = fmap (\x -> s { T.otherExtensions = x }) (f (T.otherExtensions s))-    {-# INLINE otherExtensions #-}--    oldExtensions f s = fmap (\x -> s { T.oldExtensions = x }) (f (T.oldExtensions s))-    {-# INLINE oldExtensions #-}--    extraLibs f s = fmap (\x -> s { T.extraLibs = x }) (f (T.extraLibs s))-    {-# INLINE extraLibs #-}--    extraGHCiLibs f s = fmap (\x -> s { T.extraGHCiLibs = x }) (f (T.extraGHCiLibs s))-    {-# INLINE extraGHCiLibs #-}--    extraBundledLibs f s = fmap (\x -> s { T.extraBundledLibs = x }) (f (T.extraBundledLibs s))-    {-# INLINE extraBundledLibs #-}--    extraLibFlavours f s = fmap (\x -> s { T.extraLibFlavours = x }) (f (T.extraLibFlavours s))-    {-# INLINE extraLibFlavours #-}--    extraDynLibFlavours f s = fmap (\x -> s { T.extraDynLibFlavours = x}) (f (T.extraDynLibFlavours s))-    {-# INLINE extraDynLibFlavours #-}--    extraLibDirs f s = fmap (\x -> s { T.extraLibDirs = x }) (f (T.extraLibDirs s))-    {-# INLINE extraLibDirs #-}--    includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s))-    {-# INLINE includeDirs #-}--    includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s))-    {-# INLINE includes #-}--    autogenIncludes f s = fmap (\x -> s { T.autogenIncludes = x }) (f (T.autogenIncludes s))-    {-# INLINE autogenIncludes #-}--    installIncludes f s = fmap (\x -> s { T.installIncludes = x }) (f (T.installIncludes s))-    {-# INLINE installIncludes #-}--    options f s = fmap (\x -> s { T.options = x }) (f (T.options s))-    {-# INLINE options #-}--    profOptions f s = fmap (\x -> s { T.profOptions = x }) (f (T.profOptions s))-    {-# INLINE profOptions #-}--    sharedOptions f s = fmap (\x -> s { T.sharedOptions = x }) (f (T.sharedOptions s))-    {-# INLINE sharedOptions #-}--    staticOptions f s = fmap (\x -> s { T.staticOptions = x }) (f (T.staticOptions s))-    {-# INLINE staticOptions #-}--    customFieldsBI f s = fmap (\x -> s { T.customFieldsBI = x }) (f (T.customFieldsBI s))-    {-# INLINE customFieldsBI #-}--    targetBuildDepends f s = fmap (\x -> s { T.targetBuildDepends = x }) (f (T.targetBuildDepends s))-    {-# INLINE targetBuildDepends #-}--    mixins f s = fmap (\x -> s { T.mixins = x }) (f (T.mixins s))-    {-# INLINE mixins #-}--class HasBuildInfos a where-  traverseBuildInfos :: Traversal' a BuildInfo
− src/Distribution/Types/BuildType.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}--module Distribution.Types.BuildType (-    BuildType(..),-    knownBuildTypes,-) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.CabalSpecVersion (CabalSpecVersion (..))-import Distribution.Pretty-import Distribution.Parsec--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp---- | The type of build system used by this package.-data BuildType-  = Simple      -- ^ calls @Distribution.Simple.defaultMain@-  | Configure   -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@,-                -- which invokes @configure@ to generate additional build-                -- information used by later phases.-  | Make        -- ^ calls @Distribution.Make.defaultMain@-  | Custom      -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default)-                deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary BuildType-instance Structured BuildType-instance NFData BuildType where rnf = genericRnf--knownBuildTypes :: [BuildType]-knownBuildTypes = [Simple, Configure, Make, Custom]--instance Pretty BuildType where-  pretty = Disp.text . show--instance Parsec BuildType where-  parsec = do-    name <- P.munch1 isAlphaNum-    case name of-      "Simple"    -> return Simple-      "Configure" -> return Configure-      "Custom"    -> return Custom-      "Make"      -> return Make-      "Default"   -> do-          v <- askCabalSpecVersion-          if v <= CabalSpecV1_18 -- oldest version needing this, based on hackage-tests-          then do-              parsecWarning PWTBuildTypeDefault "build-type: Default is parsed as Custom for legacy reasons. See https://github.com/haskell/cabal/issues/5020"-              return Custom-          else fail ("unknown build-type: '" ++ name ++ "'")-      _           -> fail ("unknown build-type: '" ++ name ++ "'")
− src/Distribution/Types/Component.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--module Distribution.Types.Component (-    Component(..),-    foldComponent,-    componentBuildInfo,-    componentBuildable,-    componentName,-    partitionComponents,-) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Types.Library-import Distribution.Types.ForeignLib-import Distribution.Types.Executable-import Distribution.Types.TestSuite-import Distribution.Types.Benchmark--import Distribution.Types.ComponentName-import Distribution.Types.BuildInfo--import qualified Distribution.Types.BuildInfo.Lens as L--data Component = CLib   Library-               | CFLib  ForeignLib-               | CExe   Executable-               | CTest  TestSuite-               | CBench Benchmark-               deriving (Show, Eq, Read)--instance Semigroup Component where-    CLib   l <> CLib   l' = CLib   (l <> l')-    CFLib  l <> CFLib  l' = CFLib  (l <> l')-    CExe   e <> CExe   e' = CExe   (e <> e')-    CTest  t <> CTest  t' = CTest  (t <> t')-    CBench b <> CBench b' = CBench (b <> b')-    _        <> _         = error "Cannot merge Component"--instance L.HasBuildInfo Component where-    buildInfo f (CLib l)   = CLib <$> L.buildInfo f l-    buildInfo f (CFLib l)  = CFLib <$> L.buildInfo f l-    buildInfo f (CExe e)   = CExe <$> L.buildInfo f e-    buildInfo f (CTest t)  = CTest <$> L.buildInfo f t-    buildInfo f (CBench b) = CBench <$> L.buildInfo f b--foldComponent :: (Library -> a)-              -> (ForeignLib -> a)-              -> (Executable -> a)-              -> (TestSuite -> a)-              -> (Benchmark -> a)-              -> Component-              -> a-foldComponent f _ _ _ _ (CLib   lib) = f lib-foldComponent _ f _ _ _ (CFLib  flib)= f flib-foldComponent _ _ f _ _ (CExe   exe) = f exe-foldComponent _ _ _ f _ (CTest  tst) = f tst-foldComponent _ _ _ _ f (CBench bch) = f bch--componentBuildInfo :: Component -> BuildInfo-componentBuildInfo =-  foldComponent libBuildInfo foreignLibBuildInfo buildInfo testBuildInfo benchmarkBuildInfo---- | Is a component buildable (i.e., not marked with @buildable: False@)?--- See also this note in--- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components".------ @since 2.0.0.2----componentBuildable :: Component -> Bool-componentBuildable = buildable . componentBuildInfo--componentName :: Component -> ComponentName-componentName =-  foldComponent (CLibName . libName)-                (CFLibName  . foreignLibName)-                (CExeName   . exeName)-                (CTestName  . testName)-                (CBenchName . benchmarkName)--partitionComponents-    :: [Component]-    -> ([Library], [ForeignLib], [Executable], [TestSuite], [Benchmark])-partitionComponents = foldr (foldComponent fa fb fc fd fe) ([],[],[],[],[])-  where-    fa x ~(a,b,c,d,e) = (x:a,b,c,d,e)-    fb x ~(a,b,c,d,e) = (a,x:b,c,d,e)-    fc x ~(a,b,c,d,e) = (a,b,x:c,d,e)-    fd x ~(a,b,c,d,e) = (a,b,c,x:d,e)-    fe x ~(a,b,c,d,e) = (a,b,c,d,x:e)
− src/Distribution/Types/ComponentId.hs 
@@ -1,69 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Distribution.Types.ComponentId-  ( ComponentId, unComponentId, mkComponentId-  ) where--import Prelude ()-import Distribution.Compat.Prelude-import Distribution.Utils.ShortText--import Distribution.Pretty-import Distribution.Parsec--import qualified Distribution.Compat.CharParsing as P-import Text.PrettyPrint (text)---- | A 'ComponentId' uniquely identifies the transitive source--- code closure of a component (i.e. libraries, executables).------ For non-Backpack components, this corresponds one to one with--- the 'UnitId', which serves as the basis for install paths,--- linker symbols, etc.------ Use 'mkComponentId' and 'unComponentId' to convert from/to a--- 'String'.------ This type is opaque since @Cabal-2.0@------ @since 2.0.0.2-newtype ComponentId = ComponentId ShortText-    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)---- | Construct a 'ComponentId' from a 'String'------ 'mkComponentId' is the inverse to 'unComponentId'------ Note: No validations are performed to ensure that the resulting--- 'ComponentId' is valid------ @since 2.0.0.2-mkComponentId :: String -> ComponentId-mkComponentId = ComponentId . toShortText---- | Convert 'ComponentId' to 'String'------ @since 2.0.0.2-unComponentId :: ComponentId -> String-unComponentId (ComponentId s) = fromShortText s---- | 'mkComponentId'------ @since 2.0.0.2-instance IsString ComponentId where-    fromString = mkComponentId--instance Binary ComponentId-instance Structured ComponentId--instance Pretty ComponentId where-  pretty = text . unComponentId--instance Parsec ComponentId where-  parsec = mkComponentId `fmap` P.munch1 abi_char-   where abi_char c = isAlphaNum c || c `elem` "-_."--instance NFData ComponentId where-    rnf = rnf . unComponentId
src/Distribution/Types/ComponentInclude.hs view
@@ -1,25 +1,25 @@-module Distribution.Types.ComponentInclude (-    ComponentInclude(..),-    ci_id,-    ci_pkgid,-    ci_cname-) where+module Distribution.Types.ComponentInclude+  ( ComponentInclude (..)+  , ci_id+  , ci_pkgid+  , ci_cname+  ) where -import Distribution.Types.PackageId-import Distribution.Types.ComponentName import Distribution.Types.AnnotatedId+import Distribution.Types.ComponentName+import Distribution.Types.PackageId  -- Once ci_id is refined to an 'OpenUnitId' or 'DefUnitId', -- the 'includeRequiresRn' is not so useful (because it -- includes the requirements renaming that is no longer -- needed); use 'ci_prov_renaming' instead.-data ComponentInclude id rn = ComponentInclude {-        ci_ann_id   :: AnnotatedId id,-        ci_renaming :: rn,-        -- | Did this come from an entry in @mixins@, or-        -- was implicitly generated by @build-depends@?-        ci_implicit :: Bool-    }+data ComponentInclude id rn = ComponentInclude+  { ci_ann_id :: AnnotatedId id+  , ci_renaming :: rn+  , ci_implicit :: Bool+  -- ^ Did this come from an entry in @mixins@, or+  -- was implicitly generated by @build-depends@?+  }  ci_id :: ComponentInclude id rn -> id ci_id = ann_id . ci_ann_id
src/Distribution/Types/ComponentLocalBuildInfo.hs view
@@ -1,129 +1,139 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} -module Distribution.Types.ComponentLocalBuildInfo (-  ComponentLocalBuildInfo(..),-  componentIsIndefinite,-  maybeComponentInstantiatedWith,+module Distribution.Types.ComponentLocalBuildInfo+  ( ComponentLocalBuildInfo (..)+  , componentIsIndefinite+  , maybeComponentInstantiatedWith+  , maybeComponentCompatPackageKey+  , maybeComponentExposedModules   ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.ModuleName+import Prelude ()  import Distribution.Backpack import Distribution.Compat.Graph import Distribution.Types.ComponentId-import Distribution.Types.MungedPackageId-import Distribution.Types.UnitId import Distribution.Types.ComponentName-import Distribution.Types.MungedPackageName import Distribution.Types.ModuleRenaming+import Distribution.Types.MungedPackageId+import Distribution.Types.MungedPackageName+import Distribution.Types.UnitId  import qualified Distribution.InstalledPackageInfo as Installed  -- | The first five fields are common across all algebraic variants. data ComponentLocalBuildInfo-  = LibComponentLocalBuildInfo {-    -- | It would be very convenient to store the literal Library here,-    -- but if we do that, it will get serialized (via the Binary)-    -- instance twice.  So instead we just provide the ComponentName,-    -- which can be used to find the Component in the-    -- PackageDescription.  NB: eventually, this will NOT uniquely-    -- identify the ComponentLocalBuildInfo.-    componentLocalName :: ComponentName,-    -- | The computed 'ComponentId' of this component.-    componentComponentId :: ComponentId,-    -- | The computed 'UnitId' which uniquely identifies this-    -- component.  Might be hashed.-    componentUnitId :: UnitId,-    -- | Is this an indefinite component (i.e. has unfilled holes)?-    componentIsIndefinite_ :: Bool,-    -- | How the component was instantiated-    componentInstantiatedWith :: [(ModuleName, OpenModule)],-    -- | Resolved internal and external package dependencies for this component.-    -- The 'BuildInfo' specifies a set of build dependencies that must be-    -- satisfied in terms of version ranges. This field fixes those dependencies-    -- to the specific versions available on this machine for this compiler.-    componentPackageDeps :: [(UnitId, MungedPackageId)],-    -- | The set of packages that are brought into scope during-    -- compilation, including a 'ModuleRenaming' which may used-    -- to hide or rename modules.  This is what gets translated into-    -- @-package-id@ arguments.  This is a modernized version of-    -- 'componentPackageDeps', which is kept around for BC purposes.-    componentIncludes :: [(OpenUnitId, ModuleRenaming)],-    componentExeDeps :: [UnitId],-    -- | The internal dependencies which induce a graph on the-    -- 'ComponentLocalBuildInfo' of this package.  This does NOT-    -- coincide with 'componentPackageDeps' because it ALSO records-    -- 'build-tool' dependencies on executables.  Maybe one day-    -- @cabal-install@ will also handle these correctly too!-    componentInternalDeps :: [UnitId],-    -- | Compatibility "package key" that we pass to older versions of GHC.-    componentCompatPackageKey :: String,-    -- | Compatibility "package name" that we register this component as.-    componentCompatPackageName :: MungedPackageName,-    -- | A list of exposed modules (either defined in this component,-    -- or reexported from another component.)-    componentExposedModules :: [Installed.ExposedModule],-    -- | Convenience field, specifying whether or not this is the-    -- "public library" that has the same name as the package.-    componentIsPublic :: Bool-  }-  -- TODO: refactor all these duplicates-  | FLibComponentLocalBuildInfo {-    componentLocalName :: ComponentName,-    componentComponentId :: ComponentId,-    componentUnitId :: UnitId,-    componentPackageDeps :: [(UnitId, MungedPackageId)],-    componentIncludes :: [(OpenUnitId, ModuleRenaming)],-    componentExeDeps :: [UnitId],-    componentInternalDeps :: [UnitId]-  }-  | ExeComponentLocalBuildInfo {-    componentLocalName :: ComponentName,-    componentComponentId :: ComponentId,-    componentUnitId :: UnitId,-    componentPackageDeps :: [(UnitId, MungedPackageId)],-    componentIncludes :: [(OpenUnitId, ModuleRenaming)],-    componentExeDeps :: [UnitId],-    componentInternalDeps :: [UnitId]-  }-  | TestComponentLocalBuildInfo {-    componentLocalName :: ComponentName,-    componentComponentId :: ComponentId,-    componentUnitId :: UnitId,-    componentPackageDeps :: [(UnitId, MungedPackageId)],-    componentIncludes :: [(OpenUnitId, ModuleRenaming)],-    componentExeDeps :: [UnitId],-    componentInternalDeps :: [UnitId]--  }-  | BenchComponentLocalBuildInfo {-    componentLocalName :: ComponentName,-    componentComponentId :: ComponentId,-    componentUnitId :: UnitId,-    componentPackageDeps :: [(UnitId, MungedPackageId)],-    componentIncludes :: [(OpenUnitId, ModuleRenaming)],-    componentExeDeps :: [UnitId],-    componentInternalDeps :: [UnitId]-  }-  deriving (Generic, Read, Show, Typeable)+  = LibComponentLocalBuildInfo+      { componentLocalName :: ComponentName+      -- ^ It would be very convenient to store the literal Library here,+      -- but if we do that, it will get serialized (via the Binary)+      -- instance twice.  So instead we just provide the ComponentName,+      -- which can be used to find the Component in the+      -- PackageDescription.  NB: eventually, this will NOT uniquely+      -- identify the ComponentLocalBuildInfo.+      , componentComponentId :: ComponentId+      -- ^ The computed 'ComponentId' of this component.+      , componentUnitId :: UnitId+      -- ^ The computed 'UnitId' which uniquely identifies this+      -- component.  Might be hashed.+      , componentIsIndefinite_ :: Bool+      -- ^ Is this an indefinite component (i.e. has unfilled holes)?+      , componentInstantiatedWith :: [(ModuleName, OpenModule)]+      -- ^ How the component was instantiated+      , componentPackageDeps :: [(UnitId, MungedPackageId)]+      -- ^ Resolved internal and external package dependencies for this component.+      -- The 'BuildInfo' specifies a set of build dependencies that must be+      -- satisfied in terms of version ranges. This field fixes those dependencies+      -- to the specific versions available on this machine for this compiler.+      , componentIncludes :: [(OpenUnitId, ModuleRenaming)]+      -- ^ The set of packages that are brought into scope during+      -- compilation, including a 'ModuleRenaming' which may used+      -- to hide or rename modules.  This is what gets translated into+      -- @-package-id@ arguments.  This is a modernized version of+      -- 'componentPackageDeps', which is kept around for BC purposes.+      , componentExeDeps :: [UnitId]+      , componentInternalDeps :: [UnitId]+      -- ^ The internal dependencies which induce a graph on the+      -- 'ComponentLocalBuildInfo' of this package.  This does NOT+      -- coincide with 'componentPackageDeps' because it ALSO records+      -- 'build-tool' dependencies on executables.  Maybe one day+      -- @cabal-install@ will also handle these correctly too!+      , componentCompatPackageKey :: String+      -- ^ Compatibility "package key" that we pass to older versions of GHC.+      , componentCompatPackageName :: MungedPackageName+      -- ^ Compatibility "package name" that we register this component as.+      , componentExposedModules :: [Installed.ExposedModule]+      -- ^ A list of exposed modules (either defined in this component,+      -- or reexported from another component.)+      , componentIsPublic :: Bool+      -- ^ Convenience field, specifying whether or not this is the+      -- "public library" that has the same name as the package.+      }+  | -- TODO: refactor all these duplicates+    FLibComponentLocalBuildInfo+      { componentLocalName :: ComponentName+      , componentComponentId :: ComponentId+      , componentUnitId :: UnitId+      , componentPackageDeps :: [(UnitId, MungedPackageId)]+      , componentIncludes :: [(OpenUnitId, ModuleRenaming)]+      , componentExeDeps :: [UnitId]+      , componentInternalDeps :: [UnitId]+      }+  | ExeComponentLocalBuildInfo+      { componentLocalName :: ComponentName+      , componentComponentId :: ComponentId+      , componentUnitId :: UnitId+      , componentPackageDeps :: [(UnitId, MungedPackageId)]+      , componentIncludes :: [(OpenUnitId, ModuleRenaming)]+      , componentExeDeps :: [UnitId]+      , componentInternalDeps :: [UnitId]+      }+  | TestComponentLocalBuildInfo+      { componentLocalName :: ComponentName+      , componentComponentId :: ComponentId+      , componentUnitId :: UnitId+      , componentPackageDeps :: [(UnitId, MungedPackageId)]+      , componentIncludes :: [(OpenUnitId, ModuleRenaming)]+      , componentExeDeps :: [UnitId]+      , componentInternalDeps :: [UnitId]+      }+  | BenchComponentLocalBuildInfo+      { componentLocalName :: ComponentName+      , componentComponentId :: ComponentId+      , componentUnitId :: UnitId+      , componentPackageDeps :: [(UnitId, MungedPackageId)]+      , componentIncludes :: [(OpenUnitId, ModuleRenaming)]+      , componentExeDeps :: [UnitId]+      , componentInternalDeps :: [UnitId]+      }+  deriving (Generic, Read, Show)  instance Binary ComponentLocalBuildInfo instance Structured ComponentLocalBuildInfo  instance IsNode ComponentLocalBuildInfo where-    type Key ComponentLocalBuildInfo = UnitId-    nodeKey = componentUnitId-    nodeNeighbors = componentInternalDeps+  type Key ComponentLocalBuildInfo = UnitId+  nodeKey = componentUnitId+  nodeNeighbors = componentInternalDeps  componentIsIndefinite :: ComponentLocalBuildInfo -> Bool-componentIsIndefinite LibComponentLocalBuildInfo{ componentIsIndefinite_ = b } = b+componentIsIndefinite LibComponentLocalBuildInfo{componentIsIndefinite_ = b} = b componentIsIndefinite _ = False  maybeComponentInstantiatedWith :: ComponentLocalBuildInfo -> Maybe [(ModuleName, OpenModule)] maybeComponentInstantiatedWith-    LibComponentLocalBuildInfo { componentInstantiatedWith = insts } = Just insts+  LibComponentLocalBuildInfo{componentInstantiatedWith = insts} = Just insts maybeComponentInstantiatedWith _ = Nothing++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/ComponentName.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Distribution.Types.ComponentName (-  ComponentName(..),-  showComponentName,-  componentNameStanza,-  componentNameString,-  ) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Types.UnqualComponentName-import Distribution.Types.LibraryName-import Distribution.Pretty-import Distribution.Parsec--import qualified Text.PrettyPrint as Disp-import qualified Distribution.Compat.CharParsing as P---- Libraries live in a separate namespace, so must distinguish-data ComponentName = CLibName   LibraryName-                   | CFLibName  UnqualComponentName-                   | CExeName   UnqualComponentName-                   | CTestName  UnqualComponentName-                   | CBenchName UnqualComponentName-                   deriving (Eq, Generic, Ord, Read, Show, Typeable)--instance Binary ComponentName-instance Structured ComponentName---- Build-target-ish syntax-instance Pretty ComponentName where-    pretty (CLibName lib)    = prettyLibraryNameComponent lib-    pretty (CFLibName str)   = Disp.text "flib:" <<>> pretty str-    pretty (CExeName str)    = Disp.text "exe:" <<>> pretty str-    pretty (CTestName str)   = Disp.text "test:" <<>> pretty str-    pretty (CBenchName str)  = Disp.text "bench:" <<>> pretty str--instance Parsec ComponentName where-    -- note: this works as lib/flib/... all start with different character!-    parsec = parseComposite <|> parseLib-      where-        parseLib = CLibName <$> parsecLibraryNameComponent-        parseComposite = do-            ctor <- P.choice-                [ P.string "flib:" >> return CFLibName-                , P.string "exe:" >> return CExeName-                , P.string "bench:" >> return CBenchName-                , P.string "test:" >> return CTestName-                ]-            ctor <$> parsec--showComponentName :: ComponentName -> String-showComponentName (CLibName lib)    = showLibraryName lib-showComponentName (CFLibName  name) = "foreign library '" ++ prettyShow name ++ "'"-showComponentName (CExeName   name) = "executable '" ++ prettyShow name ++ "'"-showComponentName (CTestName  name) = "test suite '" ++ prettyShow name ++ "'"-showComponentName (CBenchName name) = "benchmark '" ++ prettyShow name ++ "'"--componentNameStanza :: ComponentName -> String-componentNameStanza (CLibName lib)    = libraryNameStanza lib-componentNameStanza (CFLibName  name) = "foreign-library " ++ prettyShow name-componentNameStanza (CExeName   name) = "executable " ++ prettyShow name-componentNameStanza (CTestName  name) = "test-suite " ++ prettyShow name-componentNameStanza (CBenchName name) = "benchmark " ++ prettyShow name---- | This gets the underlying unqualified component name. In fact, it is--- guaranteed to uniquely identify a component, returning--- @Nothing@ if the 'ComponentName' was for the public--- library.-componentNameString :: ComponentName -> Maybe UnqualComponentName-componentNameString (CLibName lib) = libraryNameString lib-componentNameString (CFLibName  n) = Just n-componentNameString (CExeName   n) = Just n-componentNameString (CTestName  n) = Just n-componentNameString (CBenchName n) = Just n
− src/Distribution/Types/ComponentRequestedSpec.hs 
@@ -1,127 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Types.ComponentRequestedSpec (-    -- $buildable_vs_enabled_components--    ComponentRequestedSpec(..),-    ComponentDisabledReason(..),--    defaultComponentRequestedSpec,-    componentNameRequested,--    componentEnabled,-    componentDisabledReason,-) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Types.Component -- TODO: maybe remove me?-import Distribution.Types.ComponentName--import Distribution.Pretty (prettyShow)---- $buildable_vs_enabled_components--- #buildable_vs_enabled_components#------ = Note: Buildable versus requested versus enabled components--- What's the difference between a buildable component (ala--- 'componentBuildable'), a requested component--- (ala 'componentNameRequested'), and an enabled component (ala--- 'componentEnabled')?------ A component is __buildable__ if, after resolving flags and--- conditionals, there is no @buildable: False@ property in it.--- This is a /static/ property that arises from the--- Cabal file and the package description flattening; once we have--- a 'PackageDescription' buildability is known.------ A component is __requested__ if a user specified, via a--- the flags and arguments passed to configure, that it should be--- built.  E.g., @--enable-tests@ or @--enable-benchmarks@ request--- all tests and benchmarks, if they are provided.  What is requested--- can be read off directly from 'ComponentRequestedSpec'.  A requested--- component is not always buildable; e.g., a user may @--enable-tests@--- but one of the test suites may have @buildable: False@.------ A component is __enabled__ if it is BOTH buildable--- and requested.  Once we have a 'LocalBuildInfo', whether or not a--- component is enabled is known.------ Generally speaking, most Cabal API code cares if a component--- is enabled. (For example, if you want to run a preprocessor on each--- component prior to building them, you want to run this on each--- /enabled/ component.)------ Note that post-configuration, you will generally not see a--- non-buildable 'Component'.  This is because 'flattenPD' will drop--- any such components from 'PackageDescription'.  See #3858 for--- an example where this causes problems.---- | Describes what components are enabled by user-interaction.--- See also this note in--- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components".------ @since 2.0.0.2-data ComponentRequestedSpec-    = ComponentRequestedSpec { testsRequested      :: Bool-                             , benchmarksRequested :: Bool }-    | OneComponentRequestedSpec ComponentName-  deriving (Generic, Read, Show, Eq, Typeable)--instance Binary ComponentRequestedSpec-instance Structured ComponentRequestedSpec---- | The default set of enabled components.  Historically tests and--- benchmarks are NOT enabled by default.------ @since 2.0.0.2-defaultComponentRequestedSpec :: ComponentRequestedSpec-defaultComponentRequestedSpec = ComponentRequestedSpec False False---- | Is this component enabled?  See also this note in--- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components".------ @since 2.0.0.2-componentEnabled :: ComponentRequestedSpec -> Component -> Bool-componentEnabled enabled = isNothing . componentDisabledReason enabled---- | Is this component name enabled?  See also this note in--- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components".------ @since 2.0.0.2-componentNameRequested :: ComponentRequestedSpec -> ComponentName -> Bool-componentNameRequested enabled = isNothing . componentNameNotRequestedReason enabled---- | Is this component disabled, and if so, why?------ @since 2.0.0.2-componentDisabledReason :: ComponentRequestedSpec -> Component-                        -> Maybe ComponentDisabledReason-componentDisabledReason enabled comp-    | not (componentBuildable comp) = Just DisabledComponent-    | otherwise = componentNameNotRequestedReason enabled (componentName comp)---- | Is this component name disabled, and if so, why?------ @since 2.0.0.2-componentNameNotRequestedReason :: ComponentRequestedSpec -> ComponentName-                            -> Maybe ComponentDisabledReason-componentNameNotRequestedReason-    ComponentRequestedSpec{ testsRequested      = False } (CTestName _)-    = Just DisabledAllTests-componentNameNotRequestedReason-    ComponentRequestedSpec{ benchmarksRequested = False } (CBenchName _)-    = Just DisabledAllBenchmarks-componentNameNotRequestedReason ComponentRequestedSpec{} _ = Nothing-componentNameNotRequestedReason (OneComponentRequestedSpec cname) c-    | c == cname = Nothing-    | otherwise = Just (DisabledAllButOne (prettyShow cname))---- | A reason explaining why a component is disabled.------ @since 2.0.0.2-data ComponentDisabledReason = DisabledComponent-                             | DisabledAllTests-                             | DisabledAllBenchmarks-                             | DisabledAllButOne String
− src/Distribution/Types/CondTree.hs 
@@ -1,181 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Distribution.Types.CondTree (-    CondTree(..),-    CondBranch(..),-    condIfThen,-    condIfThenElse,-    mapCondTree,-    mapTreeConstrs,-    mapTreeConds,-    mapTreeData,-    traverseCondTreeV,-    traverseCondBranchV,-    traverseCondTreeC,-    traverseCondBranchC,-    extractCondition,-    simplifyCondTree,-    ignoreConditions,-) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Types.Condition--import qualified Distribution.Compat.Lens as L----- | A 'CondTree' is used to represent the conditional structure of--- a Cabal file, reflecting a syntax element subject to constraints,--- and then any number of sub-elements which may be enabled subject--- to some condition.  Both @a@ and @c@ are usually 'Monoid's.------ To be more concrete, consider the following fragment of a @Cabal@--- file:------ @--- build-depends: base >= 4.0--- if flag(extra)---     build-depends: base >= 4.2--- @------ One way to represent this is to have @'CondTree' 'ConfVar'--- ['Dependency'] 'BuildInfo'@.  Here, 'condTreeData' represents--- the actual fields which are not behind any conditional, while--- 'condTreeComponents' recursively records any further fields--- which are behind a conditional.  'condTreeConstraints' records--- the constraints (in this case, @base >= 4.0@) which would--- be applied if you use this syntax; in general, this is--- derived off of 'targetBuildInfo' (perhaps a good refactoring--- would be to convert this into an opaque type, with a smart--- constructor that pre-computes the dependencies.)----data CondTree v c a = CondNode-    { condTreeData        :: a-    , condTreeConstraints :: c-    , condTreeComponents  :: [CondBranch v c a]-    }-    deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable)--instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a)-instance (Structured v, Structured c, Structured a) => Structured (CondTree v c a)-instance (NFData v, NFData c, NFData a) => NFData (CondTree v c a) where rnf = genericRnf---- | A 'CondBranch' represents a conditional branch, e.g., @if--- flag(foo)@ on some syntax @a@.  It also has an optional false--- branch.----data CondBranch v c a = CondBranch-    { condBranchCondition :: Condition v-    , condBranchIfTrue    :: CondTree v c a-    , condBranchIfFalse   :: Maybe (CondTree v c a)-    }-    deriving (Show, Eq, Typeable, Data, Generic, Functor, Traversable)---- This instance is written by hand because GHC 8.0.1/8.0.2 infinite--- loops when trying to derive it with optimizations.  See--- https://gitlab.haskell.org/ghc/ghc/-/issues/13056-instance Foldable (CondBranch v c) where-    foldMap f (CondBranch _ c Nothing) = foldMap f c-    foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a--instance (Binary v, Binary c, Binary a) => Binary (CondBranch v c a)-instance (Structured v, Structured c, Structured a) => Structured (CondBranch v c a)-instance (NFData v, NFData c, NFData a) => NFData (CondBranch v c a) where rnf = genericRnf--condIfThen :: Condition v -> CondTree v c a -> CondBranch v c a-condIfThen c t = CondBranch c t Nothing--condIfThenElse :: Condition v -> CondTree v c a -> CondTree v c a -> CondBranch v c a-condIfThenElse c t e = CondBranch c t (Just e)--mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w)-            -> CondTree v c a -> CondTree w d b-mapCondTree fa fc fcnd (CondNode a c ifs) =-    CondNode (fa a) (fc c) (map g ifs)-  where-    g (CondBranch cnd t me)-        = CondBranch (fcnd cnd)-                     (mapCondTree fa fc fcnd t)-                     (fmap (mapCondTree fa fc fcnd) me)--mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a-mapTreeConstrs f = mapCondTree id f id--mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a-mapTreeConds f = mapCondTree id id f--mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b-mapTreeData f = mapCondTree f id id---- | @@Traversal@@ for the variables-traverseCondTreeV :: L.Traversal (CondTree v c a) (CondTree w c a) v w-traverseCondTreeV f (CondNode a c ifs) =-    CondNode a c <$> traverse (traverseCondBranchV f) ifs---- | @@Traversal@@ for the variables-traverseCondBranchV :: L.Traversal (CondBranch v c a) (CondBranch w c a) v w-traverseCondBranchV f (CondBranch cnd t me) = CondBranch-    <$> traverse f cnd-    <*> traverseCondTreeV f t-    <*> traverse (traverseCondTreeV f) me---- | @@Traversal@@ for the aggregated constraints-traverseCondTreeC :: L.Traversal (CondTree v c a) (CondTree v d a) c d-traverseCondTreeC f (CondNode a c ifs) =-    CondNode a <$> f c <*> traverse (traverseCondBranchC f) ifs---- | @@Traversal@@ for the aggregated constraints-traverseCondBranchC :: L.Traversal (CondBranch v c a) (CondBranch v d a) c d-traverseCondBranchC f (CondBranch cnd t me) = CondBranch cnd-    <$> traverseCondTreeC f t-    <*> traverse (traverseCondTreeC f) me----- | Extract the condition matched by the given predicate from a cond tree.------ We use this mainly for extracting buildable conditions (see the Note in--- Distribution.PackageDescription.Configuration), but the function is in fact--- more general.-extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v-extractCondition p = go-  where-    go (CondNode x _ cs) | not (p x) = Lit False-                         | otherwise = goList cs--    goList []               = Lit True-    goList (CondBranch c t e : cs) =-      let-        ct = go t-        ce = maybe (Lit True) go e-      in-        ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs---- | Flattens a CondTree using a partial flag assignment.  When a condition--- cannot be evaluated, both branches are ignored.-simplifyCondTree :: (Semigroup a, Semigroup d) =>-                    (v -> Either v Bool)-                 -> CondTree v d a-                 -> (d, a)-simplifyCondTree env (CondNode a d ifs) =-    foldl (<>) (d, a) $ mapMaybe simplifyIf ifs-  where-    simplifyIf (CondBranch cnd t me) =-        case simplifyCondition cnd env of-          (Lit True, _) -> Just $ simplifyCondTree env t-          (Lit False, _) -> fmap (simplifyCondTree env) me-          _ -> Nothing---- | Flatten a CondTree.  This will resolve the CondTree by taking all---  possible paths into account.  Note that since branches represent exclusive---  choices this may not result in a \"sane\" result.-ignoreConditions :: (Semigroup a, Semigroup c) => CondTree v c a -> (a, c)-ignoreConditions (CondNode a c ifs) = foldl (<>) (a, c) $ concatMap f ifs-  where f (CondBranch _ t me) = ignoreConditions t-                       : maybeToList (fmap ignoreConditions me)
− src/Distribution/Types/Condition.hs 
@@ -1,135 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Distribution.Types.Condition (-    Condition(..),-    cNot,-    cAnd,-    cOr,-    simplifyCondition,-) where--import Prelude ()-import Distribution.Compat.Prelude---- | A boolean expression parameterized over the variable type used.-data Condition c = Var c-                 | Lit Bool-                 | CNot (Condition c)-                 | COr (Condition c) (Condition c)-                 | CAnd (Condition c) (Condition c)-    deriving (Show, Eq, Typeable, Data, Generic)---- | Boolean negation of a 'Condition' value.-cNot :: Condition a -> Condition a-cNot (Lit b)  = Lit (not b)-cNot (CNot c) = c-cNot c        = CNot c---- | Boolean AND of two 'Condtion' values.-cAnd :: Condition a -> Condition a -> Condition a-cAnd (Lit False) _           = Lit False-cAnd _           (Lit False) = Lit False-cAnd (Lit True)  x           = x-cAnd x           (Lit True)  = x-cAnd x           y           = CAnd x y---- | Boolean OR of two 'Condition' values.-cOr :: Eq v => Condition v -> Condition v -> Condition v-cOr  (Lit True)  _           = Lit True-cOr  _           (Lit True)  = Lit True-cOr  (Lit False) x           = x-cOr  x           (Lit False) = x-cOr  c           (CNot d)-  | c == d                   = Lit True-cOr  (CNot c)    d-  | c == d                   = Lit True-cOr  x           y           = COr x y--instance Functor Condition where-  f `fmap` Var c    = Var (f c)-  _ `fmap` Lit c    = Lit c-  f `fmap` CNot c   = CNot (fmap f c)-  f `fmap` COr c d  = COr  (fmap f c) (fmap f d)-  f `fmap` CAnd c d = CAnd (fmap f c) (fmap f d)--instance Foldable Condition where-  f `foldMap` Var c    = f c-  _ `foldMap` Lit _    = mempty-  f `foldMap` CNot c   = foldMap f c-  f `foldMap` COr c d  = foldMap f c `mappend` foldMap f d-  f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d--instance Traversable Condition where-  f `traverse` Var c    = Var `fmap` f c-  _ `traverse` Lit c    = pure $ Lit c-  f `traverse` CNot c   = CNot `fmap` traverse f c-  f `traverse` COr c d  = COr  `fmap` traverse f c <*> traverse f d-  f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d--instance Applicative Condition where-  pure  = Var-  (<*>) = ap--instance Monad Condition where-  return = pure-  -- Terminating cases-  (>>=) (Lit x) _ = Lit x-  (>>=) (Var x) f = f x-  -- Recursing cases-  (>>=) (CNot  x  ) f = CNot (x >>= f)-  (>>=) (COr   x y) f = COr  (x >>= f) (y >>= f)-  (>>=) (CAnd  x y) f = CAnd (x >>= f) (y >>= f)--instance Monoid (Condition a) where-  mempty = Lit False-  mappend = (<>)--instance Semigroup (Condition a) where-  (<>) = COr--instance Alternative Condition where-  empty = mempty-  (<|>) = mappend--instance MonadPlus Condition where-  mzero = mempty-  mplus = mappend--instance Binary c => Binary (Condition c)-instance Structured c => Structured (Condition c)-instance NFData c => NFData (Condition c) where rnf = genericRnf---- | Simplify the condition and return its free variables.-simplifyCondition :: Condition c-                  -> (c -> Either d Bool)   -- ^ (partial) variable assignment-                  -> (Condition d, [d])-simplifyCondition cond i = fv . walk $ cond-  where-    walk cnd = case cnd of-      Var v   -> either Var Lit (i v)-      Lit b   -> Lit b-      CNot c  -> case walk c of-                   Lit True -> Lit False-                   Lit False -> Lit True-                   c' -> CNot c'-      COr c d -> case (walk c, walk d) of-                   (Lit False, d') -> d'-                   (Lit True, _)   -> Lit True-                   (c', Lit False) -> c'-                   (_, Lit True)   -> Lit True-                   (c',d')         -> COr c' d'-      CAnd c d -> case (walk c, walk d) of-                    (Lit False, _) -> Lit False-                    (Lit True, d') -> d'-                    (_, Lit False) -> Lit False-                    (c', Lit True) -> c'-                    (c',d')        -> CAnd c' d'-    -- gather free vars-    fv c = (c, fv' c)-    fv' c = case c of-      Var v     -> [v]-      Lit _      -> []-      CNot c'    -> fv' c'-      COr c1 c2  -> fv' c1 ++ fv' c2-      CAnd c1 c2 -> fv' c1 ++ fv' c2
− src/Distribution/Types/ConfVar.hs 
@@ -1,25 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Types.ConfVar (-    ConfVar(..),-    ) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Types.Flag-import Distribution.Types.VersionRange-import Distribution.Compiler-import Distribution.System---- | A @ConfVar@ represents the variable type used.-data ConfVar = OS OS-             | Arch Arch-             | PackageFlag FlagName-             | Impl CompilerFlavor VersionRange-    deriving (Eq, Show, Typeable, Data, Generic)--instance Binary ConfVar-instance Structured ConfVar--instance NFData ConfVar where rnf = genericRnf
− src/Distribution/Types/Dependency.hs 
@@ -1,179 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.Types.Dependency-  ( Dependency(..)-  , mkDependency-  , depPkgName-  , depVerRange-  , depLibraries-  , simplifyDependency-  , mainLibSet-  ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Types.VersionRange (isAnyVersionLight)-import Distribution.Version            (VersionRange, anyVersion, simplifyVersionRange)--import Distribution.CabalSpecVersion-import Distribution.Compat.CharParsing        (char, spaces)-import Distribution.Compat.Parsing            (between, option)-import Distribution.Parsec-import Distribution.Pretty-import Distribution.Types.LibraryName-import Distribution.Types.PackageName-import Distribution.Types.UnqualComponentName--import qualified Distribution.Compat.NonEmptySet as NES-import qualified Text.PrettyPrint                as PP---- | Describes a dependency on a source package (API)------ /Invariant:/ package name does not appear as 'LSubLibName' in--- set of library names.----data Dependency = Dependency-                    PackageName-                    VersionRange-                    (NonEmptySet LibraryName)-                    -- ^ The set of libraries required from the package.-                    -- Only the selected libraries will be built.-                    -- It does not affect the cabal-install solver yet.-                  deriving (Generic, Read, Show, Eq, Typeable, Data)--depPkgName :: Dependency -> PackageName-depPkgName (Dependency pn _ _) = pn--depVerRange :: Dependency -> VersionRange-depVerRange (Dependency _ vr _) = vr--depLibraries :: Dependency -> NonEmptySet LibraryName-depLibraries (Dependency _ _ cs) = cs---- | Smart constructor of 'Dependency'.------ If 'PackageName' is appears as 'LSubLibName' in a set of sublibraries,--- it is automatically converted to 'LMainLibName'.------ @since 3.4.0.0----mkDependency :: PackageName -> VersionRange -> NonEmptySet LibraryName -> Dependency-mkDependency pn vr lb = Dependency pn vr (NES.map conv lb)-  where-    pn' = packageNameToUnqualComponentName pn--    conv l@LMainLibName                 = l-    conv l@(LSubLibName ln) | ln == pn' = LMainLibName-                            | otherwise = l--instance Binary Dependency-instance Structured Dependency-instance NFData Dependency where rnf = genericRnf---- |------ >>> prettyShow $ Dependency "pkg" anyVersion mainLibSet--- "pkg"------ >>> prettyShow $ Dependency "pkg" anyVersion $ NES.insert (LSubLibName "sublib") mainLibSet--- "pkg:{pkg, sublib}"------ >>> prettyShow $ Dependency "pkg" anyVersion $ NES.singleton (LSubLibName "sublib")--- "pkg:sublib"------ >>> prettyShow $ Dependency "pkg" anyVersion $ NES.insert (LSubLibName "sublib-b") $ NES.singleton (LSubLibName "sublib-a")--- "pkg:{sublib-a, sublib-b}"----instance Pretty Dependency where-    pretty (Dependency name ver sublibs) = withSubLibs (pretty name) <+> pver-      where-        -- TODO: change to isAnyVersion after #6736-        pver | isAnyVersionLight ver = PP.empty-             | otherwise             = pretty ver--        withSubLibs doc = case NES.toList sublibs of-            [LMainLibName]   -> doc-            [LSubLibName uq] -> doc <<>> PP.colon <<>> pretty uq-            _                -> doc <<>> PP.colon <<>> PP.braces prettySublibs--        prettySublibs = PP.hsep $ PP.punctuate PP.comma $ prettySublib <$> NES.toList sublibs--        prettySublib LMainLibName     = PP.text $ unPackageName name-        prettySublib (LSubLibName un) = PP.text $ unUnqualComponentName un---- |------ >>> simpleParsec "mylib:sub" :: Maybe Dependency--- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub") :| [])))------ >>> simpleParsec "mylib:{sub1,sub2}" :: Maybe Dependency--- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")])))------ >>> simpleParsec "mylib:{ sub1 , sub2 }" :: Maybe Dependency--- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")])))------ >>> simpleParsec "mylib:{ sub1 , sub2 } ^>= 42" :: Maybe Dependency--- Just (Dependency (PackageName "mylib") (MajorBoundVersion (mkVersion [42])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")])))------ >>> simpleParsec "mylib:{ } ^>= 42" :: Maybe Dependency--- Nothing------ >>> traverse_ print (map simpleParsec ["mylib:mylib", "mylib:{mylib}", "mylib:{mylib,sublib}" ] :: [Maybe Dependency])--- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| [])))--- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| [])))--- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| [LSubLibName (UnqualComponentName "sublib")])))------ Spaces around colon are not allowed:------ >>> map simpleParsec ["mylib: sub", "mylib :sub", "mylib: {sub1,sub2}", "mylib :{sub1,sub2}"] :: [Maybe Dependency]--- [Nothing,Nothing,Nothing,Nothing]------ Sublibrary syntax is accepted since @cabal-version: 3.0@------ >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe Dependency]--- [Nothing,Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub") :| [])))]----instance Parsec Dependency where-    parsec = do-        name <- parsec--        libs <- option mainLibSet $ do-          _ <- char ':'-          versionGuardMultilibs-          parsecWarning PWTExperimental "colon specifier is experimental feature (issue #5660)"-          NES.singleton <$> parseLib <|> parseMultipleLibs--        spaces -- https://github.com/haskell/cabal/issues/5846--        ver  <- parsec <|> pure anyVersion-        return $ mkDependency name ver libs-      where-        parseLib          = LSubLibName <$> parsec-        parseMultipleLibs = between-            (char '{' *> spaces)-            (spaces *> char '}')-            (NES.fromNonEmpty <$> parsecCommaNonEmpty parseLib)--versionGuardMultilibs :: CabalParsing m => m ()-versionGuardMultilibs = do-  csv <- askCabalSpecVersion-  when (csv < CabalSpecV3_0) $ fail $ unwords-    [ "Sublibrary dependency syntax used."-    , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'."-    , "Alternatively, if you are depending on an internal library, you can write"-    , "directly the library name as it were a package."-    ]---- | Library set with main library.------ @since 3.4.0.0-mainLibSet :: NonEmptySet LibraryName-mainLibSet = NES.singleton LMainLibName---- | Simplify the 'VersionRange' expression in a 'Dependency'.--- See 'simplifyVersionRange'.----simplifyDependency :: Dependency -> Dependency-simplifyDependency (Dependency name range comps) =-  Dependency name (simplifyVersionRange range) comps
− src/Distribution/Types/DependencyMap.hs 
@@ -1,57 +0,0 @@-module Distribution.Types.DependencyMap (-    DependencyMap,-    toDepMap,-    fromDepMap,-    constrainBy,-) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Types.Dependency-import Distribution.Types.LibraryName-import Distribution.Types.PackageName-import Distribution.Types.PackageVersionConstraint-import Distribution.Version--import qualified Data.Map.Lazy as Map---- | A map of dependencies.  Newtyped since the default monoid instance is not---   appropriate.  The monoid instance uses 'intersectVersionRanges'.-newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName (VersionRange, NonEmptySet LibraryName) }-  deriving (Show, Read)--instance Monoid DependencyMap where-    mempty = DependencyMap Map.empty-    mappend = (<>)--instance Semigroup DependencyMap where-    (DependencyMap a) <> (DependencyMap b) =-        DependencyMap (Map.unionWith intersectVersionRangesAndJoinComponents a b)--intersectVersionRangesAndJoinComponents :: (VersionRange, NonEmptySet LibraryName)-                                        -> (VersionRange, NonEmptySet LibraryName)-                                        -> (VersionRange, NonEmptySet LibraryName)-intersectVersionRangesAndJoinComponents (va, ca) (vb, cb) =-  (intersectVersionRanges va vb, ca <> cb)--toDepMap :: [Dependency] -> DependencyMap-toDepMap ds =-  DependencyMap $ Map.fromListWith intersectVersionRangesAndJoinComponents [ (p,(vr,cs)) | Dependency p vr cs <- ds ]--fromDepMap :: DependencyMap -> [Dependency]-fromDepMap m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDependencyMap m) ]---- Apply extra constraints to a dependency map.--- Combines dependencies where the result will only contain keys from the left--- (first) map.  If a key also exists in the right map, both constraints will--- be intersected.-constrainBy-    :: DependencyMap-    -> [PackageVersionConstraint]-    -> DependencyMap-constrainBy = foldl' tightenConstraint where-    tightenConstraint (DependencyMap l) (PackageVersionConstraint pn vr) = DependencyMap $-        case Map.lookup pn l of-            Nothing        -> l-            Just (vr', cs) -> Map.insert pn (intersectVersionRanges vr' vr, cs) l
+ src/Distribution/Types/DumpBuildInfo.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.DumpBuildInfo+  ( DumpBuildInfo (..)+  ) where++import Distribution.Compat.Prelude++data DumpBuildInfo+  = NoDumpBuildInfo+  | DumpBuildInfo+  deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic)++instance Binary DumpBuildInfo+instance Structured DumpBuildInfo
− src/Distribution/Types/ExeDependency.hs 
@@ -1,71 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.Types.ExeDependency-  ( ExeDependency(..)-  , qualifiedExeName-  ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty-import Distribution.Types.ComponentName-import Distribution.Types.PackageName-import Distribution.Types.UnqualComponentName-import Distribution.Version                   (VersionRange, anyVersion, isAnyVersion)--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as PP---- | Describes a dependency on an executable from a package----data ExeDependency = ExeDependency-                     PackageName-                     UnqualComponentName -- name of executable component of package-                     VersionRange-                     deriving (Generic, Read, Show, Eq, Typeable, Data)--instance Binary ExeDependency-instance Structured ExeDependency-instance NFData ExeDependency where rnf = genericRnf--instance Pretty ExeDependency where-  pretty (ExeDependency name exe ver) =-      pretty name <<>> PP.colon <<>> pretty exe PP.<+> pver-    where-      pver | isAnyVersion ver = PP.empty-           | otherwise        = pretty ver---- | ------ Examples------ >>> simpleParsec "happy:happy" :: Maybe ExeDependency--- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [0])))------ >>> simpleParsec "happy:happy >= 1.19.12" :: Maybe ExeDependency--- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [1,19,12])))------ >>> simpleParsec "happy:happy>=1.19.12" :: Maybe ExeDependency--- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [1,19,12])))------ >>> simpleParsec "happy : happy >= 1.19.12" :: Maybe ExeDependency--- Nothing------ >>> simpleParsec "happy: happy >= 1.19.12" :: Maybe ExeDependency--- Nothing------ >>> simpleParsec "happy :happy >= 1.19.12" :: Maybe ExeDependency--- Nothing----instance Parsec ExeDependency where-    parsec = do-        name <- parsec-        _    <- P.char ':'-        exe  <- lexemeParsec-        ver  <- parsec <|> pure anyVersion-        return (ExeDependency name exe ver)--qualifiedExeName :: ExeDependency -> ComponentName-qualifiedExeName (ExeDependency _ ucn _) = CExeName ucn
− src/Distribution/Types/Executable.hs 
@@ -1,65 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Distribution.Types.Executable (-    Executable(..),-    emptyExecutable,-    exeModules,-    exeModulesAutogen-) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Types.BuildInfo-import Distribution.Types.UnqualComponentName-import Distribution.Types.ExecutableScope-import Distribution.ModuleName--import qualified Distribution.Types.BuildInfo.Lens as L--data Executable = Executable {-        exeName    :: UnqualComponentName,-        modulePath :: FilePath,-        exeScope   :: ExecutableScope,-        buildInfo  :: BuildInfo-    }-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance L.HasBuildInfo Executable where-    buildInfo f l = (\x -> l { buildInfo = x }) <$> f (buildInfo l)--instance Binary Executable-instance Structured Executable-instance NFData Executable where rnf = genericRnf--instance Monoid Executable where-  mempty = gmempty-  mappend = (<>)--instance Semigroup Executable where-  a <> b = Executable{-    exeName    = combine' exeName,-    modulePath = combine modulePath,-    exeScope   = combine exeScope,-    buildInfo  = combine buildInfo-  }-    where combine field = field a `mappend` field b-          combine' field = case ( unUnqualComponentName $ field a-                                , unUnqualComponentName $ field b) of-                      ("", _) -> field b-                      (_, "") -> field a-                      (x, y) -> error $ "Ambiguous values for executable field: '"-                                  ++ x ++ "' and '" ++ y ++ "'"--emptyExecutable :: Executable-emptyExecutable = mempty---- | Get all the module names from an exe-exeModules :: Executable -> [ModuleName]-exeModules exe = otherModules (buildInfo exe)---- | Get all the auto generated module names from an exe--- This are a subset of 'exeModules'.-exeModulesAutogen :: Executable -> [ModuleName]-exeModulesAutogen exe = autogenModules (buildInfo exe)
− src/Distribution/Types/Executable/Lens.hs 
@@ -1,31 +0,0 @@-module Distribution.Types.Executable.Lens (-    Executable,-    module Distribution.Types.Executable.Lens,-    ) where--import Distribution.Compat.Lens-import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Types.BuildInfo           (BuildInfo)-import Distribution.Types.Executable          (Executable)-import Distribution.Types.ExecutableScope     (ExecutableScope)-import Distribution.Types.UnqualComponentName (UnqualComponentName)--import qualified Distribution.Types.Executable as T--exeName :: Lens' Executable UnqualComponentName-exeName f s = fmap (\x -> s { T.exeName = x }) (f (T.exeName s))-{-# INLINE exeName #-}--modulePath :: Lens' Executable String-modulePath f s = fmap (\x -> s { T.modulePath = x }) (f (T.modulePath s))-{-# INLINE modulePath #-}--exeScope :: Lens' Executable ExecutableScope-exeScope f s = fmap (\x -> s { T.exeScope = x }) (f (T.exeScope s))-{-# INLINE exeScope #-}--exeBuildInfo :: Lens' Executable BuildInfo-exeBuildInfo f s = fmap (\x -> s { T.buildInfo = x }) (f (T.buildInfo s))-{-# INLINE exeBuildInfo #-}
− src/Distribution/Types/ExecutableScope.hs 
@@ -1,43 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}--module Distribution.Types.ExecutableScope (-    ExecutableScope(..),-) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Pretty-import Distribution.Parsec--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp--data ExecutableScope = ExecutablePublic-                     | ExecutablePrivate-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Pretty ExecutableScope where-    pretty ExecutablePublic       = Disp.text "public"-    pretty ExecutablePrivate      = Disp.text "private"--instance Parsec ExecutableScope where-    parsec = P.try pub <|> pri where-        pub = ExecutablePublic  <$ P.string "public"-        pri = ExecutablePrivate <$ P.string "private"--instance Binary ExecutableScope-instance Structured ExecutableScope-instance NFData ExecutableScope where rnf = genericRnf---- | 'Any' like semigroup, where 'ExecutablePrivate' is 'Any True'-instance Semigroup ExecutableScope where-    ExecutablePublic    <> x = x-    x@ExecutablePrivate <> _ = x---- | 'mempty' = 'ExecutablePublic'-instance Monoid ExecutableScope where-    mempty = ExecutablePublic-    mappend = (<>)
− src/Distribution/Types/ExposedModule.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Types.ExposedModule where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Backpack-import Distribution.ModuleName-import Distribution.Parsec-import Distribution.Pretty--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp--data ExposedModule-   = ExposedModule {-       exposedName      :: ModuleName,-       exposedReexport  :: Maybe OpenModule-     }-  deriving (Eq, Generic, Read, Show, Typeable)--instance Pretty ExposedModule where-    pretty (ExposedModule m reexport) =-        Disp.hsep [ pretty m-                  , case reexport of-                     Just m' -> Disp.hsep [Disp.text "from", pretty m']-                     Nothing -> Disp.empty-                  ]--instance Parsec ExposedModule where-    parsec = do-        m <- parsecMaybeQuoted parsec-        P.spaces--        reexport <- P.optional $ do-            _ <- P.string "from"-            P.skipSpaces1-            parsec--        return (ExposedModule m reexport)--instance Binary ExposedModule-instance Structured ExposedModule-instance NFData ExposedModule where rnf = genericRnf
− src/Distribution/Types/Flag.hs 
@@ -1,346 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Distribution.Types.Flag (-    -- * Package flag-    PackageFlag(..),-    emptyFlag,-    -- * Flag name-    FlagName,-    mkFlagName,-    unFlagName,-    -- * Flag assignment-    FlagAssignment,-    mkFlagAssignment,-    unFlagAssignment,-    lookupFlagAssignment,-    insertFlagAssignment,-    diffFlagAssignment,-    findDuplicateFlagAssignments,-    nullFlagAssignment,-    showFlagValue,-    dispFlagAssignment,-    showFlagAssignment,-    parsecFlagAssignment,-    parsecFlagAssignmentNonEmpty,-    -- ** Legacy formats-    legacyShowFlagAssignment,-    legacyShowFlagAssignment',-    legacyParsecFlagAssignment,-    ) where--import Prelude ()-import Distribution.Compat.Prelude-import Distribution.Utils.ShortText-import Distribution.Utils.Generic (lowercase)--import Distribution.Parsec-import Distribution.Pretty--import qualified Data.Map as Map-import qualified Text.PrettyPrint as Disp-import qualified Distribution.Compat.CharParsing as P---- -------------------------------------------------------------------------------- The Flag' type---- | A flag can represent a feature to be included, or a way of linking---   a target against its dependencies, or in fact whatever you can think of.-data PackageFlag = MkPackageFlag-    { flagName        :: FlagName-    , flagDescription :: String-    , flagDefault     :: Bool-    , flagManual      :: Bool-    }-    deriving (Show, Eq, Typeable, Data, Generic)--instance Binary PackageFlag-instance Structured PackageFlag-instance NFData PackageFlag where rnf = genericRnf---- | A 'PackageFlag' initialized with default parameters.-emptyFlag :: FlagName -> PackageFlag-emptyFlag name = MkPackageFlag-    { flagName        = name-    , flagDescription = ""-    , flagDefault     = True-    , flagManual      = False-    }---- | A 'FlagName' is the name of a user-defined configuration flag------ Use 'mkFlagName' and 'unFlagName' to convert from/to a 'String'.------ This type is opaque since @Cabal-2.0@------ @since 2.0.0.2-newtype FlagName = FlagName ShortText-    deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData)---- | Construct a 'FlagName' from a 'String'------ 'mkFlagName' is the inverse to 'unFlagName'------ Note: No validations are performed to ensure that the resulting--- 'FlagName' is valid------ @since 2.0.0.2-mkFlagName :: String -> FlagName-mkFlagName = FlagName . toShortText---- | 'mkFlagName'------ @since 2.0.0.2-instance IsString FlagName where-    fromString = mkFlagName---- | Convert 'FlagName' to 'String'------ @since 2.0.0.2-unFlagName :: FlagName -> String-unFlagName (FlagName s) = fromShortText s--instance Binary FlagName-instance Structured FlagName--instance Pretty FlagName where-    pretty = Disp.text . unFlagName--instance Parsec FlagName where-    -- Note:  we don't check that FlagName doesn't have leading dash,-    -- cabal check will do that.-    parsec = mkFlagName . lowercase <$> parsec'-      where-        parsec' = (:) <$> lead <*> rest-        lead = P.satisfy (\c ->  isAlphaNum c || c == '_')-        rest = P.munch (\c -> isAlphaNum c ||  c == '_' || c == '-')---- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to--- 'Bool' flag values. It represents the flags chosen by the user or--- discovered during configuration. For example @--flags=foo --flags=-bar@--- becomes @[("foo", True), ("bar", False)]@------ TODO: Why we record the multiplicity of the flag?----newtype FlagAssignment-  = FlagAssignment { getFlagAssignment :: Map.Map FlagName (Int, Bool) }-  deriving (Binary, Generic, NFData, Typeable)--instance Structured FlagAssignment--instance Eq FlagAssignment where-  (==) (FlagAssignment m1) (FlagAssignment m2)-    = fmap snd m1 == fmap snd m2--instance Ord FlagAssignment where-  compare (FlagAssignment m1) (FlagAssignment m2)-    = fmap snd m1 `compare` fmap snd m2---- | Combines pairs of values contained in the 'FlagAssignment' Map.------ The last flag specified takes precedence, and we record the number--- of times we have seen the flag.----combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool)-combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2)---- The 'Semigroup' instance currently is right-biased.------ If duplicate flags are specified, we want the last flag specified to--- take precedence and we want to know how many times the flag has been--- specified so that we have the option of warning the user about--- supplying duplicate flags.-instance Semigroup FlagAssignment where-  (<>) (FlagAssignment m1) (FlagAssignment m2)-    = FlagAssignment (Map.unionWith combineFlagValues m1 m2)--instance Monoid FlagAssignment where-  mempty = FlagAssignment Map.empty-  mappend = (<>)---- | Construct a 'FlagAssignment' from a list of flag/value pairs.------ If duplicate flags occur in the input list, the later entries--- in the list will take precedence.------ @since 2.2.0-mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment-mkFlagAssignment =-  FlagAssignment .-  Map.fromListWith (flip combineFlagValues) . fmap (fmap (\b -> (1, b)))---- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs.------ @ 'null' ('findDuplicateFlagAssignments' fa) ==> ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @------ @since 2.2.0-unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)]-unFlagAssignment = fmap (fmap snd) . Map.toList . getFlagAssignment---- | Test whether 'FlagAssignment' is empty.------ @since 2.2.0-nullFlagAssignment :: FlagAssignment -> Bool-nullFlagAssignment = Map.null . getFlagAssignment---- | Lookup the value for a flag------ Returns 'Nothing' if the flag isn't contained in the 'FlagAssignment'.------ @since 2.2.0-lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool-lookupFlagAssignment fn = fmap snd . Map.lookup fn . getFlagAssignment---- | Insert or update the boolean value of a flag.------ If the flag is already present in the 'FlagAssigment', the--- value will be updated and the fact that multiple values have--- been provided for that flag will be recorded so that a--- warning can be generated later on.------ @since 2.2.0-insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment--- TODO: this currently just shadows prior values for an existing--- flag; rather than enforcing uniqueness at construction, it's--- verified later on via `D.C.Dependency.configuredPackageProblems`-insertFlagAssignment flag val =-  FlagAssignment .-  Map.insertWith (flip combineFlagValues) flag (1, val) .  getFlagAssignment---- | Remove all flag-assignments from the first 'FlagAssignment' that--- are contained in the second 'FlagAssignment'------ NB/TODO: This currently only removes flag assignments which also--- match the value assignment! We should review the code which uses--- this operation to figure out if this it's not enough to only--- compare the flagnames without the values.------ @since 2.2.0-diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment-diffFlagAssignment fa1 fa2 = FlagAssignment-  (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2))---- | Find the 'FlagName's that have been listed more than once.------ @since 2.2.0-findDuplicateFlagAssignments :: FlagAssignment -> [FlagName]-findDuplicateFlagAssignments =-  Map.keys . Map.filter ((> 1) . fst) . getFlagAssignment---- | @since 2.2.0-instance Read FlagAssignment where-    readsPrec p s = [ (FlagAssignment x, rest) | (x,rest) <- readsPrec p s ]---- | @since 2.2.0-instance Show FlagAssignment where-    showsPrec p (FlagAssignment xs) = showsPrec p xs---- | String representation of a flag-value pair.-showFlagValue :: (FlagName, Bool) -> String-showFlagValue (f, True)   = '+' : unFlagName f-showFlagValue (f, False)  = '-' : unFlagName f---- | @since 3.4.0.0-instance Pretty FlagAssignment where-    pretty = dispFlagAssignment---- |------ >>> simpleParsec "" :: Maybe FlagAssignment--- Just (fromList [])------ >>> simpleParsec "+foo -bar" :: Maybe FlagAssignment--- Just (fromList [(FlagName "bar",(1,False)),(FlagName "foo",(1,True))])------ >>> simpleParsec "-none -any" :: Maybe FlagAssignment--- Just (fromList [(FlagName "any",(1,False)),(FlagName "none",(1,False))])------ >>> simpleParsec "+foo -foo +foo +foo" :: Maybe FlagAssignment--- Just (fromList [(FlagName "foo",(4,True))])------ >>> simpleParsec "+foo -bar baz" :: Maybe FlagAssignment--- Nothing------ @since 3.4.0.0----instance Parsec FlagAssignment where-    parsec = parsecFlagAssignment---- | Pretty-prints a flag assignment.-dispFlagAssignment :: FlagAssignment -> Disp.Doc-dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment---- | Parses a flag assignment.-parsecFlagAssignment :: CabalParsing m => m FlagAssignment-parsecFlagAssignment = mkFlagAssignment <$>-                       P.sepBy (onFlag <|> offFlag) P.skipSpaces1-  where-    onFlag = do-        _ <- P.char '+'-        f <- parsec-        return (f, True)-    offFlag = do-        _ <- P.char '-'-        f <- parsec-        return (f, False)---- | Parse a non-empty flag assignment------ The flags have to explicitly start with minus or plus.------ @since 3.4.0.0-parsecFlagAssignmentNonEmpty :: CabalParsing m => m FlagAssignment-parsecFlagAssignmentNonEmpty = mkFlagAssignment . toList <$>-    P.sepByNonEmpty (onFlag <|> offFlag) P.skipSpaces1-  where-    onFlag = do-        _ <- P.char '+'-        f <- parsec-        return (f, True)-    offFlag = do-        _ <- P.char '-'-        f <- parsec-        return (f, False)---- | Show flag assignment.------ @since 3.4.0.0-showFlagAssignment :: FlagAssignment -> String-showFlagAssignment = prettyShow . dispFlagAssignment------------------------------------------------------------------------------------ Legacy: without requiring +------------------------------------------------------------------------------------ | We need this as far as we support custom setups older than 2.2.0.0------ @since 3.4.0.0-legacyShowFlagAssignment :: FlagAssignment -> String-legacyShowFlagAssignment =-    prettyShow .  Disp.hsep . map Disp.text . legacyShowFlagAssignment'---- | @since 3.4.0.0-legacyShowFlagAssignment' :: FlagAssignment -> [String]-legacyShowFlagAssignment' = map legacyShowFlagValue . unFlagAssignment---- | @since 3.4.0.0-legacyShowFlagValue :: (FlagName, Bool) -> String-legacyShowFlagValue (f, True)   =       unFlagName f-legacyShowFlagValue (f, False)  = '-' : unFlagName f---- |--- We need this as far as we support custom setups older than 2.2.0.0------ @since 3.4.0.0-legacyParsecFlagAssignment :: CabalParsing m => m FlagAssignment-legacyParsecFlagAssignment = mkFlagAssignment <$>-                       P.sepBy (onFlag <|> offFlag) P.skipSpaces1-  where-    onFlag = do-        _ <- P.optional (P.char '+')-        f <- parsec-        return (f, True)-    offFlag = do-        _ <- P.char '-'-        f <- parsec-        return (f, False)
− src/Distribution/Types/ForeignLib.hs 
@@ -1,199 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}--module Distribution.Types.ForeignLib(-    ForeignLib(..),-    emptyForeignLib,-    foreignLibModules,-    foreignLibIsShared,-    foreignLibVersion,--    LibVersionInfo,-    mkLibVersionInfo,-    libVersionInfoCRA,-    libVersionNumber,-    libVersionNumberShow,-    libVersionMajor-) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.ModuleName-import Distribution.Parsec-import Distribution.Pretty-import Distribution.System-import Distribution.Types.BuildInfo-import Distribution.Types.ForeignLibOption-import Distribution.Types.ForeignLibType-import Distribution.Types.UnqualComponentName-import Distribution.Version--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp-import qualified Text.Read                       as Read--import qualified Distribution.Types.BuildInfo.Lens as L---- | A foreign library stanza is like a library stanza, except that--- the built code is intended for consumption by a non-Haskell client.-data ForeignLib = ForeignLib {-      -- | Name of the foreign library-      foreignLibName       :: UnqualComponentName-      -- | What kind of foreign library is this (static or dynamic).-    , foreignLibType       :: ForeignLibType-      -- | What options apply to this foreign library (e.g., are we-      -- merging in all foreign dependencies.)-    , foreignLibOptions    :: [ForeignLibOption]-      -- | Build information for this foreign library.-    , foreignLibBuildInfo  :: BuildInfo-      -- | Libtool-style version-info data to compute library version.-      -- Refer to the libtool documentation on the-      -- current:revision:age versioning scheme.-    , foreignLibVersionInfo :: Maybe LibVersionInfo-      -- | Linux library version-    , foreignLibVersionLinux :: Maybe Version--      -- | (Windows-specific) module definition files-      ---      -- This is a list rather than a maybe field so that we can flatten-      -- the condition trees (for instance, when creating an sdist)-    , foreignLibModDefFile :: [FilePath]-    }-    deriving (Generic, Show, Read, Eq, Typeable, Data)--data LibVersionInfo = LibVersionInfo Int Int Int deriving (Data, Eq, Generic, Typeable)--instance Ord LibVersionInfo where-    LibVersionInfo c r _ `compare` LibVersionInfo c' r' _ =-        case c `compare` c' of-            EQ -> r `compare` r'-            e  -> e--instance Show LibVersionInfo where-    showsPrec d (LibVersionInfo c r a) = showParen (d > 10)-        $ showString "mkLibVersionInfo "-        . showsPrec 11 (c,r,a)--instance Read LibVersionInfo where-    readPrec = Read.parens $ do-        Read.Ident "mkLibVersionInfo" <- Read.lexP-        t <- Read.step Read.readPrec-        return (mkLibVersionInfo t)--instance Binary LibVersionInfo-instance Structured LibVersionInfo-instance NFData LibVersionInfo where rnf = genericRnf--instance Pretty LibVersionInfo where-    pretty (LibVersionInfo c r a)-      = Disp.hcat $ Disp.punctuate (Disp.char ':') $ map Disp.int [c,r,a]--instance Parsec LibVersionInfo where-    parsec = do-        c <- P.integral-        (r, a) <- P.option (0,0) $ do-            _ <- P.char ':'-            r <- P.integral-            a <- P.option 0 $ do-                _ <- P.char ':'-                P.integral-            return (r,a)-        return $ mkLibVersionInfo (c,r,a)---- | Construct 'LibVersionInfo' from @(current, revision, age)@--- numbers.------ For instance, @mkLibVersionInfo (3,0,0)@ constructs a--- 'LibVersionInfo' representing the version-info @3:0:0@.------ All version components must be non-negative.-mkLibVersionInfo :: (Int, Int, Int) -> LibVersionInfo-mkLibVersionInfo (c,r,a) = LibVersionInfo c r a---- | From a given 'LibVersionInfo', extract the @(current, revision,--- age)@ numbers.-libVersionInfoCRA :: LibVersionInfo -> (Int, Int, Int)-libVersionInfoCRA (LibVersionInfo c r a) = (c,r,a)---- | Given a version-info field, produce a @major.minor.build@ version-libVersionNumber :: LibVersionInfo -> (Int, Int, Int)-libVersionNumber (LibVersionInfo c r a) = (c-a , a , r)---- | Given a version-info field, return @"major.minor.build"@ as a--- 'String'-libVersionNumberShow :: LibVersionInfo -> String-libVersionNumberShow v =-    let (major, minor, build) = libVersionNumber v-    in show major ++ "." ++ show minor ++ "." ++ show build---- | Return the @major@ version of a version-info field.-libVersionMajor :: LibVersionInfo -> Int-libVersionMajor (LibVersionInfo c _ a) = c-a--instance L.HasBuildInfo ForeignLib where-    buildInfo f l = (\x -> l { foreignLibBuildInfo = x }) <$> f (foreignLibBuildInfo l)--instance Binary ForeignLib-instance Structured ForeignLib-instance NFData ForeignLib where rnf = genericRnf--instance Semigroup ForeignLib where-  a <> b = ForeignLib {-      foreignLibName         = combine'  foreignLibName-    , foreignLibType         = combine   foreignLibType-    , foreignLibOptions      = combine   foreignLibOptions-    , foreignLibBuildInfo    = combine   foreignLibBuildInfo-    , foreignLibVersionInfo  = combine'' foreignLibVersionInfo-    , foreignLibVersionLinux = combine'' foreignLibVersionLinux-    , foreignLibModDefFile   = combine   foreignLibModDefFile-    }-    where combine field = field a `mappend` field b-          combine' field = case ( unUnqualComponentName $ field a-                                , unUnqualComponentName $ field b) of-            ("", _) -> field b-            (_, "") -> field a-            (x, y) -> error $ "Ambiguous values for executable field: '"-                                  ++ x ++ "' and '" ++ y ++ "'"-          combine'' field = field b--instance Monoid ForeignLib where-  mempty = ForeignLib {-      foreignLibName         = mempty-    , foreignLibType         = ForeignLibTypeUnknown-    , foreignLibOptions      = []-    , foreignLibBuildInfo    = mempty-    , foreignLibVersionInfo  = Nothing-    , foreignLibVersionLinux = Nothing-    , foreignLibModDefFile   = []-    }-  mappend = (<>)---- | An empty foreign library.-emptyForeignLib :: ForeignLib-emptyForeignLib = mempty---- | Modules defined by a foreign library.-foreignLibModules :: ForeignLib -> [ModuleName]-foreignLibModules = otherModules . foreignLibBuildInfo---- | Is the foreign library shared?-foreignLibIsShared :: ForeignLib -> Bool-foreignLibIsShared = foreignLibTypeIsShared . foreignLibType---- | Get a version number for a foreign library.--- If we're on Linux, and a Linux version is specified, use that.--- If we're on Linux, and libtool-style version-info is specified, translate--- that field into appropriate version numbers.--- Otherwise, this feature is unsupported so we don't return any version data.-foreignLibVersion :: ForeignLib -> OS -> [Int]-foreignLibVersion flib Linux =-  case foreignLibVersionLinux flib of-    Just v  -> versionNumbers v-    Nothing ->-      case foreignLibVersionInfo flib of-        Just v' ->-          let (major, minor, build) = libVersionNumber v'-          in [major, minor, build]-        Nothing -> []-foreignLibVersion _ _ = []
− src/Distribution/Types/ForeignLib/Lens.hs 
@@ -1,45 +0,0 @@-module Distribution.Types.ForeignLib.Lens (-    ForeignLib,-    module Distribution.Types.ForeignLib.Lens,-    ) where--import Distribution.Compat.Lens-import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Types.BuildInfo           (BuildInfo)-import Distribution.Types.ForeignLib          (ForeignLib, LibVersionInfo)-import Distribution.Types.ForeignLibOption    (ForeignLibOption)-import Distribution.Types.ForeignLibType      (ForeignLibType)-import Distribution.Types.UnqualComponentName (UnqualComponentName)-import Distribution.Version                   (Version)--import qualified Distribution.Types.ForeignLib as T--foreignLibName :: Lens' ForeignLib UnqualComponentName-foreignLibName f s = fmap (\x -> s { T.foreignLibName = x }) (f (T.foreignLibName s))-{-# INLINE foreignLibName #-}--foreignLibType :: Lens' ForeignLib ForeignLibType-foreignLibType f s = fmap (\x -> s { T.foreignLibType = x }) (f (T.foreignLibType s))-{-# INLINE foreignLibType #-}--foreignLibOptions :: Lens' ForeignLib [ForeignLibOption]-foreignLibOptions f s = fmap (\x -> s { T.foreignLibOptions = x }) (f (T.foreignLibOptions s))-{-# INLINE foreignLibOptions #-}--foreignLibBuildInfo :: Lens' ForeignLib BuildInfo-foreignLibBuildInfo f s = fmap (\x -> s { T.foreignLibBuildInfo = x }) (f (T.foreignLibBuildInfo s))-{-# INLINE foreignLibBuildInfo #-}--foreignLibVersionInfo :: Lens' ForeignLib (Maybe LibVersionInfo)-foreignLibVersionInfo f s = fmap (\x -> s { T.foreignLibVersionInfo = x }) (f (T.foreignLibVersionInfo s))-{-# INLINE foreignLibVersionInfo #-}--foreignLibVersionLinux :: Lens' ForeignLib (Maybe Version)-foreignLibVersionLinux f s = fmap (\x -> s { T.foreignLibVersionLinux = x }) (f (T.foreignLibVersionLinux s))-{-# INLINE foreignLibVersionLinux #-}--foreignLibModDefFile :: Lens' ForeignLib [FilePath]-foreignLibModDefFile f s = fmap (\x -> s { T.foreignLibModDefFile = x }) (f (T.foreignLibModDefFile s))-{-# INLINE foreignLibModDefFile #-}
− src/Distribution/Types/ForeignLibOption.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}--module Distribution.Types.ForeignLibOption(-    ForeignLibOption(..)-) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Pretty-import Distribution.Parsec--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp--data ForeignLibOption =-     -- | Merge in all dependent libraries (i.e., use-     -- @ghc -shared -static@ rather than just record-     -- the dependencies, ala @ghc -shared -dynamic@).-     -- This option is compulsory on Windows and unsupported-     -- on other platforms.-     ForeignLibStandalone-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Pretty ForeignLibOption where-  pretty ForeignLibStandalone = Disp.text "standalone"--instance Parsec ForeignLibOption where-  parsec = do-    name <- P.munch1 (\c -> isAlphaNum c || c == '-')-    case name of-      "standalone" -> return ForeignLibStandalone-      _            -> fail "unrecognized foreign-library option"--instance Binary ForeignLibOption-instance Structured ForeignLibOption-instance NFData ForeignLibOption where rnf = genericRnf
− src/Distribution/Types/ForeignLibType.hs 
@@ -1,69 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}--module Distribution.Types.ForeignLibType(-    ForeignLibType(..),-    knownForeignLibTypes,-    foreignLibTypeIsShared,-) where--import Prelude ()-import Distribution.Compat.Prelude-import Distribution.PackageDescription.Utils--import Distribution.Pretty-import Distribution.Parsec--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp---- | What kind of foreign library is to be built?-data ForeignLibType =-      -- | A native shared library (@.so@ on Linux, @.dylib@ on OSX, or-      -- @.dll@ on Windows).-      ForeignLibNativeShared-      -- | A native static library (not currently supported.)-    | ForeignLibNativeStatic-      -- TODO: Maybe this should record a string?-    | ForeignLibTypeUnknown-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Pretty ForeignLibType where-  pretty ForeignLibNativeShared = Disp.text "native-shared"-  pretty ForeignLibNativeStatic = Disp.text "native-static"-  pretty ForeignLibTypeUnknown  = Disp.text "unknown"--instance Parsec ForeignLibType where-  parsec = do-    name <- P.munch1 (\c -> isAlphaNum c || c == '-')-    return $ case name of-      "native-shared" -> ForeignLibNativeShared-      "native-static" -> ForeignLibNativeStatic-      _               -> ForeignLibTypeUnknown--instance Binary ForeignLibType-instance Structured ForeignLibType-instance NFData ForeignLibType where rnf = genericRnf--instance Semigroup ForeignLibType where-  ForeignLibTypeUnknown <> b = b-  a <> ForeignLibTypeUnknown = a-  _ <> _ = error "Ambiguous foreign library type"--instance Monoid ForeignLibType where-  mempty = ForeignLibTypeUnknown-  mappend = (<>)--knownForeignLibTypes :: [ForeignLibType]-knownForeignLibTypes = [-      ForeignLibNativeShared-    , ForeignLibNativeStatic-    ]--foreignLibTypeIsShared :: ForeignLibType -> Bool-foreignLibTypeIsShared t =-    case t of-      ForeignLibNativeShared -> True-      ForeignLibNativeStatic -> False-      ForeignLibTypeUnknown  -> cabalBug "Unknown foreign library type"
− src/Distribution/Types/GenericPackageDescription.hs 
@@ -1,105 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Distribution.Types.GenericPackageDescription (-    GenericPackageDescription(..),-    emptyGenericPackageDescription,-) where--import Prelude ()-import Distribution.Compat.Prelude---- lens-import Distribution.Compat.Lens                     as L-import qualified Distribution.Types.BuildInfo.Lens  as L--import Distribution.Types.PackageDescription--import Distribution.Types.Benchmark-import Distribution.Types.CondTree-import Distribution.Types.ConfVar-import Distribution.Types.Dependency-import Distribution.Types.Executable-import Distribution.Types.Flag-import Distribution.Types.ForeignLib-import Distribution.Types.Library-import Distribution.Types.TestSuite-import Distribution.Types.UnqualComponentName-import Distribution.Package-import Distribution.Version---- ------------------------------------------------------------------------------ The 'GenericPackageDescription' type--data GenericPackageDescription =-  GenericPackageDescription-  { packageDescription :: PackageDescription-  , gpdScannedVersion  :: Maybe Version-    -- ^ This is a version as specified in source.-    --   We populate this field in index reading for dummy GPDs,-    --   only when GPD reading failed, but scanning haven't.-    ---    --   Cabal-the-library never produces GPDs with Just as gpdScannedVersion.-    ---    --   Perfectly, PackageIndex should have sum type, so we don't need to-    --   have dummy GPDs.-  , genPackageFlags    :: [PackageFlag]-  , condLibrary        :: Maybe (CondTree ConfVar [Dependency] Library)-  , condSubLibraries   :: [( UnqualComponentName-                           , CondTree ConfVar [Dependency] Library )]-  , condForeignLibs    :: [( UnqualComponentName-                           , CondTree ConfVar [Dependency] ForeignLib )]-  , condExecutables    :: [( UnqualComponentName-                           , CondTree ConfVar [Dependency] Executable )]-  , condTestSuites     :: [( UnqualComponentName-                           , CondTree ConfVar [Dependency] TestSuite )]-  , condBenchmarks     :: [( UnqualComponentName-                           , CondTree ConfVar [Dependency] Benchmark )]-  }-    deriving (Show, Eq, Typeable, Data, Generic)--instance Package GenericPackageDescription where-  packageId = packageId . packageDescription--instance Binary GenericPackageDescription-instance Structured GenericPackageDescription-instance NFData GenericPackageDescription where rnf = genericRnf--emptyGenericPackageDescription :: GenericPackageDescription-emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescription Nothing [] Nothing [] [] [] [] []---- -------------------------------------------------------------------------------- Traversal Instances--instance L.HasBuildInfos GenericPackageDescription where-    traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) =-        GenericPackageDescription-            <$> L.traverseBuildInfos f p-            <*> pure v-            <*> pure a1-            <*> (traverse . traverseCondTreeBuildInfo) f x1-            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x2-            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x3-            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x4-            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x5-            <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x6-      where---- We use this traversal to keep [Dependency] field in CondTree up to date.-traverseCondTreeBuildInfo-    :: forall f comp v. (Applicative f, L.HasBuildInfo comp)-    => LensLike' f (CondTree v [Dependency] comp) L.BuildInfo-traverseCondTreeBuildInfo g = node where-    mkCondNode :: comp -> [CondBranch v [Dependency] comp] -> CondTree v [Dependency] comp-    mkCondNode comp branches = CondNode comp (view L.targetBuildDepends comp) branches--    node (CondNode comp _ branches) = mkCondNode-        <$> L.buildInfo g comp-        <*> traverse branch branches--    branch (CondBranch v x y) = CondBranch v-        <$> node x-        <*> traverse node y
− src/Distribution/Types/GenericPackageDescription/Lens.hs 
@@ -1,131 +0,0 @@-{-# LANGUAGE Rank2Types #-}-module Distribution.Types.GenericPackageDescription.Lens (-    GenericPackageDescription,-    PackageFlag,-    FlagName,-    ConfVar (..),-    module Distribution.Types.GenericPackageDescription.Lens,-    ) where--import Prelude()-import Distribution.Compat.Prelude-import Distribution.Compat.Lens--import qualified Distribution.Types.GenericPackageDescription as T---- We import types from their packages, so we can remove unused imports--- and have wider inter-module dependency graph-import Distribution.Types.CondTree (CondTree)-import Distribution.Types.Dependency (Dependency)-import Distribution.Types.Executable (Executable)-import Distribution.Types.PackageDescription (PackageDescription)-import Distribution.Types.Benchmark (Benchmark)-import Distribution.Types.ForeignLib (ForeignLib)-import Distribution.Types.GenericPackageDescription (GenericPackageDescription(GenericPackageDescription) )-import Distribution.Types.Flag (PackageFlag(MkPackageFlag), FlagName)-import Distribution.Types.ConfVar (ConfVar (..))-import Distribution.Types.Library (Library)-import Distribution.Types.TestSuite (TestSuite)-import Distribution.Types.UnqualComponentName (UnqualComponentName)-import Distribution.System (Arch, OS)-import Distribution.Compiler (CompilerFlavor)-import Distribution.Version (Version, VersionRange)------------------------------------------------------------------------------------ GenericPackageDescription----------------------------------------------------------------------------------packageDescription :: Lens' GenericPackageDescription PackageDescription-packageDescription f s = fmap (\x -> s { T.packageDescription = x }) (f (T.packageDescription s))-{-# INLINE packageDescription #-}--gpdScannedVersion :: Lens' GenericPackageDescription (Maybe Version)-gpdScannedVersion f s = fmap (\x -> s { T.gpdScannedVersion = x }) (f (T.gpdScannedVersion s))-{-# INLINE gpdScannedVersion #-}--genPackageFlags :: Lens' GenericPackageDescription [PackageFlag]-genPackageFlags f s = fmap (\x -> s { T.genPackageFlags = x }) (f (T.genPackageFlags s))-{-# INLINE genPackageFlags #-}--condLibrary :: Lens' GenericPackageDescription (Maybe (CondTree ConfVar [Dependency] Library))-condLibrary f s = fmap (\x -> s { T.condLibrary = x }) (f (T.condLibrary s))-{-# INLINE condLibrary #-}--condSubLibraries :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Library))]-condSubLibraries f s = fmap (\x -> s { T.condSubLibraries = x }) (f (T.condSubLibraries s))-{-# INLINE condSubLibraries #-}--condForeignLibs :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] ForeignLib))]-condForeignLibs f s = fmap (\x -> s { T.condForeignLibs = x }) (f (T.condForeignLibs s))-{-# INLINE condForeignLibs #-}--condExecutables :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Executable))]-condExecutables f s = fmap (\x -> s { T.condExecutables = x }) (f (T.condExecutables s))-{-# INLINE condExecutables #-}--condTestSuites :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] TestSuite))]-condTestSuites f s = fmap (\x -> s { T.condTestSuites = x }) (f (T.condTestSuites s))-{-# INLINE condTestSuites #-}--condBenchmarks :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Benchmark))]-condBenchmarks f s = fmap (\x -> s { T.condBenchmarks = x }) (f (T.condBenchmarks s))-{-# INLINE condBenchmarks #-}--allCondTrees-  :: Applicative f-  => (forall a. CondTree ConfVar [Dependency] a-          -> f (CondTree ConfVar [Dependency] a))-  -> GenericPackageDescription-  -> f GenericPackageDescription-allCondTrees f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) =-    GenericPackageDescription-        <$> pure p-        <*> pure v-        <*> pure a1-        <*> traverse f x1-        <*> (traverse . _2) f x2-        <*> (traverse . _2) f x3-        <*> (traverse . _2) f x4-        <*> (traverse . _2) f x5-        <*> (traverse . _2) f x6------------------------------------------------------------------------------------- Flag----------------------------------------------------------------------------------flagName :: Lens' PackageFlag FlagName-flagName f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag y1 x2 x3 x4) (f x1)-{-# INLINE flagName #-}--flagDescription :: Lens' PackageFlag String-flagDescription f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 y1 x3 x4) (f x2)-{-# INLINE flagDescription #-}--flagDefault :: Lens' PackageFlag Bool-flagDefault f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 x2 y1 x4) (f x3)-{-# INLINE flagDefault #-}--flagManual :: Lens' PackageFlag Bool-flagManual f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 x2 x3 y1) (f x4)-{-# INLINE flagManual #-}------------------------------------------------------------------------------------ ConfVar----------------------------------------------------------------------------------_OS :: Traversal' ConfVar OS-_OS f (OS os) = OS <$> f os-_OS _ x       = pure x--_Arch :: Traversal' ConfVar Arch-_Arch f (Arch arch) = Arch <$> f arch-_Arch _ x           = pure x--_PackageFlag :: Traversal' ConfVar FlagName-_PackageFlag f (PackageFlag flag) = PackageFlag <$> f flag-_PackageFlag _ x                  = pure x--_Impl :: Traversal' ConfVar (CompilerFlavor, VersionRange)-_Impl f (Impl cf vr) = uncurry Impl <$> f (cf, vr)-_Impl _ x            = pure x
src/Distribution/Types/GivenComponent.hs view
@@ -1,13 +1,15 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-module Distribution.Types.GivenComponent (-  GivenComponent(..)-) where +module Distribution.Types.GivenComponent+  ( GivenComponent (..)+  , PromisedComponent (..)+  ) where+ import Distribution.Compat.Prelude  import Distribution.Types.ComponentId import Distribution.Types.LibraryName+import Distribution.Types.PackageId import Distribution.Types.PackageName  -- | A 'GivenComponent' represents a library depended on and explicitly@@ -16,13 +18,30 @@ -- It enables Cabal to know which 'ComponentId' to associate with a library -- -- @since 2.3.0.0-data GivenComponent =-  GivenComponent-    { givenComponentPackage :: PackageName-    , givenComponentName    :: LibraryName -- --dependency is for libraries-                                           -- only, not for any component-    , givenComponentId      :: ComponentId }-  deriving (Generic, Read, Show, Eq, Typeable)+data GivenComponent = GivenComponent+  { givenComponentPackage :: PackageName+  , givenComponentName :: LibraryName -- --dependency is for libraries+  -- only, not for any component+  , givenComponentId :: ComponentId+  }+  deriving (Generic, Read, Show, Eq)  instance Binary GivenComponent instance Structured GivenComponent++-- | A 'PromisedComponent' represents a promised library depended on and explicitly+-- specified by the user/client with @--promised-dependency@+--+-- It enables Cabal to know which 'ComponentId' to associate with a library+--+-- @since 3.14.0.0+data PromisedComponent = PromisedComponent+  { promisedComponentPackage :: PackageId+  , promisedComponentName :: LibraryName -- --dependency is for libraries+  -- only, not for any component+  , promisedComponentId :: ComponentId+  }+  deriving (Generic, Read, Show, Eq)++instance Binary PromisedComponent+instance Structured PromisedComponent
− src/Distribution/Types/HookedBuildInfo.hs 
@@ -1,66 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Distribution.Types.HookedBuildInfo (-    HookedBuildInfo,-    emptyHookedBuildInfo,-  ) where---- import Distribution.Compat.Prelude-import Distribution.Types.BuildInfo-import Distribution.Types.UnqualComponentName---- | 'HookedBuildInfo' is mechanism that hooks can use to--- override the 'BuildInfo's inside packages.  One example--- use-case (which is used in core libraries today) is as--- a way of passing flags which are computed by a configure--- script into Cabal.  In this case, the autoconf build type adds--- hooks to read in a textual 'HookedBuildInfo' format prior--- to doing any operations.------ Quite honestly, this mechanism is a massive hack since we shouldn't--- be editing the 'PackageDescription' data structure (it's easy--- to assume that this data structure shouldn't change and--- run into bugs, see for example 1c20a6328579af9e37677d507e2e9836ef70ab9d).--- But it's a bit convenient, because there isn't another data--- structure that allows adding extra 'BuildInfo' style things.------ In any case, a lot of care has to be taken to make sure the--- 'HookedBuildInfo' is applied to the 'PackageDescription'.  In--- general this process occurs in "Distribution.Simple", which is--- responsible for orchestrating the hooks mechanism.  The--- general strategy:------      1. We run the pre-hook, which produces a 'HookedBuildInfo'---         (e.g., in the Autoconf case, it reads it out from a file).---      2. We sanity-check the hooked build info with---         'sanityCheckHookedBuildInfo'.---      3. We update our 'PackageDescription' (either freshly read---         or cached from 'LocalBuildInfo') with 'updatePackageDescription'.------         In principle, we are also supposed to update the copy of---         the 'PackageDescription' stored in 'LocalBuildInfo'---         at 'localPkgDescr'.  Unfortunately, in practice, there---         are lots of Custom setup scripts which fail to update---         'localPkgDescr' so you really shouldn't rely on it.---         It's not DEPRECATED because there are legitimate uses---         for it, but... yeah.  Sharp knife.  See---         <https://github.com/haskell/cabal/issues/3606>---         for more information on the issue.------ It is not well-specified whether or not a 'HookedBuildInfo' applied--- at configure time is persistent to the 'LocalBuildInfo'.  The--- fact that 'HookedBuildInfo' is passed to 'confHook' MIGHT SUGGEST--- that the 'HookedBuildInfo' is applied at this time, but actually--- since 9317b67e6122ab14e53f81b573bd0ecb388eca5a it has been ONLY used--- to create a modified package description that we check for problems:--- it is never actually saved to the LBI.  Since 'HookedBuildInfo' is--- applied monoidally to the existing build infos (and it is not an--- idempotent monoid), it could break things to save it, since we--- are obligated to apply any new 'HookedBuildInfo' and then we'd--- get the effect twice.  But this does mean we have to re-apply--- it every time. Hey, it's more flexibility.-type HookedBuildInfo = (Maybe BuildInfo, [(UnqualComponentName, BuildInfo)])--emptyHookedBuildInfo :: HookedBuildInfo-emptyHookedBuildInfo = (Nothing, [])
− src/Distribution/Types/IncludeRenaming.hs 
@@ -1,68 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}--module Distribution.Types.IncludeRenaming (-    IncludeRenaming(..),-    defaultIncludeRenaming,-    isDefaultIncludeRenaming,-) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Types.ModuleRenaming--import qualified Distribution.Compat.CharParsing as P-import           Distribution.Parsec-import           Distribution.Pretty-import           Text.PrettyPrint           (text)-import qualified Text.PrettyPrint           as Disp---- ------------------------------------------------------------------------------ Module renaming---- | A renaming on an include: (provides renaming, requires renaming)-data IncludeRenaming-    = IncludeRenaming {-        includeProvidesRn :: ModuleRenaming,-        includeRequiresRn :: ModuleRenaming-    }-    deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)--instance Binary IncludeRenaming-instance Structured IncludeRenaming--instance NFData IncludeRenaming where rnf = genericRnf---- | The 'defaultIncludeRenaming' applied when you only @build-depends@--- on a package.-defaultIncludeRenaming :: IncludeRenaming-defaultIncludeRenaming = IncludeRenaming defaultRenaming defaultRenaming---- | Is an 'IncludeRenaming' the default one?-isDefaultIncludeRenaming :: IncludeRenaming -> Bool-isDefaultIncludeRenaming (IncludeRenaming p r) = isDefaultRenaming p && isDefaultRenaming r--instance Pretty IncludeRenaming where-    pretty (IncludeRenaming prov_rn req_rn) =-        pretty prov_rn-          <+> (if isDefaultRenaming req_rn-                then Disp.empty-                else text "requires" <+> pretty req_rn)--instance Parsec IncludeRenaming where-    parsec = do-        prov_rn <- parsec-        req_rn <- P.option defaultRenaming $ P.try $ do-            P.spaces -- no need to be space-            _ <- P.string "requires"-            P.spaces-            parsec-        -- Requirements don't really care if they're mentioned-        -- or not (since you can't thin a requirement.)  But-        -- we have a little hack in Configure to combine-        -- the provisions and requirements together before passing-        -- them to GHC, and so the most neutral choice for a requirement-        -- is for the "with" field to be False, so we correctly-        -- thin provisions.-        return (IncludeRenaming prov_rn req_rn)
− src/Distribution/Types/InstalledPackageInfo.hs 
@@ -1,173 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE TypeFamilies       #-}-{-# LANGUAGE OverloadedStrings  #-}-module Distribution.Types.InstalledPackageInfo (-    InstalledPackageInfo (..),-    emptyInstalledPackageInfo,-    mungedPackageId,-    mungedPackageName,-    AbiDependency (..),-    ExposedModule (..),-    ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Backpack-import Distribution.Compat.Graph            (IsNode (..))-import Distribution.License-import Distribution.ModuleName-import Distribution.Package                 hiding (installedUnitId)-import Distribution.Types.AbiDependency-import Distribution.Types.ExposedModule-import Distribution.Types.LibraryName-import Distribution.Types.LibraryVisibility-import Distribution.Types.MungedPackageId-import Distribution.Types.MungedPackageName-import Distribution.Version                 (nullVersion)-import Distribution.Utils.ShortText         (ShortText)--import qualified Distribution.Package as Package-import qualified Distribution.SPDX    as SPDX---- -------------------------------------------------------------------------------- The InstalledPackageInfo type---- For BC reasons, we continue to name this record an InstalledPackageInfo;--- but it would more accurately be called an InstalledUnitInfo with Backpack-data InstalledPackageInfo-   = InstalledPackageInfo {-        -- these parts (sourcePackageId, installedUnitId) are-        -- exactly the same as PackageDescription-        sourcePackageId   :: PackageId,-        sourceLibName     :: LibraryName,-        installedComponentId_ :: ComponentId,-        libVisibility     :: LibraryVisibility,-        installedUnitId   :: UnitId,-        -- INVARIANT: if this package is definite, OpenModule's-        -- OpenUnitId directly records UnitId.  If it is-        -- indefinite, OpenModule is always an OpenModuleVar-        -- with the same ModuleName as the key.-        instantiatedWith  :: [(ModuleName, OpenModule)],-        compatPackageKey  :: String,-        license           :: Either SPDX.License License,-        copyright         :: !ShortText,-        maintainer        :: !ShortText,-        author            :: !ShortText,-        stability         :: !ShortText,-        homepage          :: !ShortText,-        pkgUrl            :: !ShortText,-        synopsis          :: !ShortText,-        description       :: !ShortText,-        category          :: !ShortText,-        -- these parts are required by an installed package only:-        abiHash           :: AbiHash,-        indefinite        :: Bool,-        exposed           :: Bool,-        -- INVARIANT: if the package is definite, OpenModule's-        -- OpenUnitId directly records UnitId.-        exposedModules    :: [ExposedModule],-        hiddenModules     :: [ModuleName],-        trusted           :: Bool,-        importDirs        :: [FilePath],-        libraryDirs       :: [FilePath],-        libraryDynDirs    :: [FilePath],  -- ^ overrides 'libraryDirs'-        dataDir           :: FilePath,-        hsLibraries       :: [String],-        extraLibraries    :: [String],-        extraGHCiLibraries:: [String],    -- overrides extraLibraries for GHCi-        includeDirs       :: [FilePath],-        includes          :: [String],-        -- INVARIANT: if the package is definite, UnitId is NOT-        -- a ComponentId of an indefinite package-        depends           :: [UnitId],-        abiDepends        :: [AbiDependency],-        ccOptions         :: [String],-        cxxOptions        :: [String],-        ldOptions         :: [String],-        frameworkDirs     :: [FilePath],-        frameworks        :: [String],-        haddockInterfaces :: [FilePath],-        haddockHTMLs      :: [FilePath],-        pkgRoot           :: Maybe FilePath-    }-    deriving (Eq, Generic, Typeable, Read, Show)--instance Binary InstalledPackageInfo-instance Structured InstalledPackageInfo--instance NFData InstalledPackageInfo where rnf = genericRnf--instance Package.HasMungedPackageId InstalledPackageInfo where-   mungedId = mungedPackageId--instance Package.Package InstalledPackageInfo where-   packageId = sourcePackageId--instance Package.HasUnitId InstalledPackageInfo where-   installedUnitId = installedUnitId--instance Package.PackageInstalled InstalledPackageInfo where-   installedDepends = depends--instance IsNode InstalledPackageInfo where-    type Key InstalledPackageInfo = UnitId-    nodeKey       = installedUnitId-    nodeNeighbors = depends--mungedPackageId :: InstalledPackageInfo -> MungedPackageId-mungedPackageId ipi =-    MungedPackageId (mungedPackageName ipi) (packageVersion ipi)---- | Returns the munged package name, which we write into @name@ for--- compatibility with old versions of GHC.-mungedPackageName :: InstalledPackageInfo -> MungedPackageName-mungedPackageName ipi = MungedPackageName (packageName ipi) (sourceLibName ipi)--emptyInstalledPackageInfo :: InstalledPackageInfo-emptyInstalledPackageInfo-   = InstalledPackageInfo {-        sourcePackageId   = PackageIdentifier (mkPackageName "") nullVersion,-        sourceLibName     = LMainLibName,-        installedComponentId_ = mkComponentId "",-        installedUnitId   = mkUnitId "",-        instantiatedWith  = [],-        compatPackageKey  = "",-        license           = Left SPDX.NONE,-        copyright         = "",-        maintainer        = "",-        author            = "",-        stability         = "",-        homepage          = "",-        pkgUrl            = "",-        synopsis          = "",-        description       = "",-        category          = "",-        abiHash           = mkAbiHash "",-        indefinite        = False,-        exposed           = False,-        exposedModules    = [],-        hiddenModules     = [],-        trusted           = False,-        importDirs        = [],-        libraryDirs       = [],-        libraryDynDirs    = [],-        dataDir           = "",-        hsLibraries       = [],-        extraLibraries    = [],-        extraGHCiLibraries= [],-        includeDirs       = [],-        includes          = [],-        depends           = [],-        abiDepends        = [],-        ccOptions         = [],-        cxxOptions        = [],-        ldOptions         = [],-        frameworkDirs     = [],-        frameworks        = [],-        haddockInterfaces = [],-        haddockHTMLs      = [],-        pkgRoot           = Nothing,-        libVisibility     = LibraryVisibilityPrivate-    }
− src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs 
@@ -1,317 +0,0 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE RecordWildCards       #-}-module Distribution.Types.InstalledPackageInfo.FieldGrammar (-    ipiFieldGrammar,-    ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Backpack-import Distribution.CabalSpecVersion-import Distribution.Compat.Lens               (Lens', (&), (.~))-import Distribution.Compat.Newtype-import Distribution.FieldGrammar-import Distribution.FieldGrammar.FieldDescrs-import Distribution.License-import Distribution.ModuleName-import Distribution.Package-import Distribution.Parsec-import Distribution.Pretty-import Distribution.Types.LibraryName-import Distribution.Types.LibraryVisibility-import Distribution.Types.MungedPackageName-import Distribution.Types.UnqualComponentName-import Distribution.Version--import qualified Data.Char                       as Char-import qualified Data.Map                        as Map-import qualified Distribution.Compat.CharParsing as P-import qualified Distribution.SPDX               as SPDX-import qualified Text.PrettyPrint                as Disp--import Distribution.Types.InstalledPackageInfo--import qualified Distribution.Types.InstalledPackageInfo.Lens as L-import qualified Distribution.Types.PackageId.Lens            as L---- Note: GHC goes nuts and inlines everything,--- One can see e.g. in -ddump-simpl-stats:------ 34886 KnownBranch---  8197 wild1_ixF0------ https://gitlab.haskell.org/ghc/ghc/-/issues/13253 might be the cause.------ The workaround is to prevent GHC optimising the code:-infixl 4 <@>-(<@>) :: Applicative f => f (a -> b) -> f a -> f b-f <@> x = f <*> x-{-# NOINLINE (<@>) #-}--ipiFieldGrammar-    :: ( FieldGrammar c g, Applicative (g InstalledPackageInfo), Applicative (g Basic)-       , c (Identity AbiHash)-       , c (Identity LibraryVisibility)-       , c (Identity PackageName)-       , c (Identity UnitId)-       , c (Identity UnqualComponentName)-       , c (List FSep (Identity AbiDependency) AbiDependency)-       , c (List FSep (Identity UnitId) UnitId)-       , c (List FSep (MQuoted ModuleName) ModuleName)-       , c (List FSep FilePathNT String)-       , c (List FSep Token String)-       , c (MQuoted MungedPackageName)-       , c (MQuoted Version)-       , c CompatPackageKey-       , c ExposedModules-       , c InstWith-       , c SpecLicenseLenient-       )-    => g InstalledPackageInfo InstalledPackageInfo-ipiFieldGrammar = mkInstalledPackageInfo-    -- Deprecated fields-    <$> monoidalFieldAla    "hugs-options"         (alaList' FSep Token)         unitedList-        --- https://github.com/haskell/cabal/commit/40f3601e17024f07e0da8e64d3dd390177ce908b-        ^^^ deprecatedSince CabalSpecV1_22 "hugs isn't supported anymore"-    -- Very basic fields: name, version, package-name, lib-name and visibility-    <@> blurFieldGrammar basic basicFieldGrammar-    -- Basic fields-    <@> optionalFieldDef    "id"                                                 L.installedUnitId (mkUnitId "")-    <@> optionalFieldDefAla "instantiated-with"    InstWith                      L.instantiatedWith []-    <@> optionalFieldDefAla "key"                  CompatPackageKey              L.compatPackageKey ""-    <@> optionalFieldDefAla "license"              SpecLicenseLenient            L.license (Left SPDX.NONE)-    <@> freeTextFieldDefST  "copyright"                                          L.copyright-    <@> freeTextFieldDefST  "maintainer"                                         L.maintainer-    <@> freeTextFieldDefST  "author"                                             L.author-    <@> freeTextFieldDefST  "stability"                                          L.stability-    <@> freeTextFieldDefST  "homepage"                                           L.homepage-    <@> freeTextFieldDefST  "package-url"                                        L.pkgUrl-    <@> freeTextFieldDefST  "synopsis"                                           L.synopsis-    <@> freeTextFieldDefST  "description"                                        L.description-    <@> freeTextFieldDefST  "category"                                           L.category-    -- Installed fields-    <@> optionalFieldDef    "abi"                                                L.abiHash (mkAbiHash "")-    <@> booleanFieldDef     "indefinite"                                         L.indefinite False-    <@> booleanFieldDef     "exposed"                                            L.exposed False-    <@> monoidalFieldAla    "exposed-modules"      ExposedModules                L.exposedModules-    <@> monoidalFieldAla    "hidden-modules"       (alaList' FSep MQuoted)       L.hiddenModules-    <@> booleanFieldDef     "trusted"                                            L.trusted False-    <@> monoidalFieldAla    "import-dirs"          (alaList' FSep FilePathNT)    L.importDirs-    <@> monoidalFieldAla    "library-dirs"         (alaList' FSep FilePathNT)    L.libraryDirs-    <@> monoidalFieldAla    "dynamic-library-dirs" (alaList' FSep FilePathNT)    L.libraryDynDirs-    <@> optionalFieldDefAla "data-dir"             FilePathNT                    L.dataDir ""-    <@> monoidalFieldAla    "hs-libraries"         (alaList' FSep Token)         L.hsLibraries-    <@> monoidalFieldAla    "extra-libraries"      (alaList' FSep Token)         L.extraLibraries-    <@> monoidalFieldAla    "extra-ghci-libraries" (alaList' FSep Token)         L.extraGHCiLibraries-    <@> monoidalFieldAla    "include-dirs"         (alaList' FSep FilePathNT)    L.includeDirs-    <@> monoidalFieldAla    "includes"             (alaList' FSep FilePathNT)    L.includes-    <@> monoidalFieldAla    "depends"              (alaList FSep)                L.depends-    <@> monoidalFieldAla    "abi-depends"          (alaList FSep)                L.abiDepends-    <@> monoidalFieldAla    "cc-options"           (alaList' FSep Token)         L.ccOptions-    <@> monoidalFieldAla    "cxx-options"          (alaList' FSep Token)         L.cxxOptions-    <@> monoidalFieldAla    "ld-options"           (alaList' FSep Token)         L.ldOptions-    <@> monoidalFieldAla    "framework-dirs"       (alaList' FSep FilePathNT)    L.frameworkDirs-    <@> monoidalFieldAla    "frameworks"           (alaList' FSep Token)         L.frameworks-    <@> monoidalFieldAla    "haddock-interfaces"   (alaList' FSep FilePathNT)    L.haddockInterfaces-    <@> monoidalFieldAla    "haddock-html"         (alaList' FSep FilePathNT)    L.haddockHTMLs-    <@> optionalFieldAla    "pkgroot"              FilePathNT                    L.pkgRoot-  where-    mkInstalledPackageInfo _ Basic {..} = InstalledPackageInfo-        -- _basicPkgName is not used-        -- setMaybePackageId says it can be no-op.-        (PackageIdentifier pn _basicVersion)-        (combineLibraryName ln _basicLibName)-        (mkComponentId "") -- installedComponentId_, not in use-        _basicLibVisibility-      where-        MungedPackageName pn ln = _basicName-{-# SPECIALIZE ipiFieldGrammar :: FieldDescrs InstalledPackageInfo InstalledPackageInfo #-}-{-# SPECIALIZE ipiFieldGrammar :: ParsecFieldGrammar InstalledPackageInfo InstalledPackageInfo #-}-{-# SPECIALIZE ipiFieldGrammar :: PrettyFieldGrammar InstalledPackageInfo InstalledPackageInfo #-}---- (forall b. [b]) ~ ()-unitedList :: Lens' a [b]-unitedList f s = s <$ f []------------------------------------------------------------------------------------ Helper functions------------------------------------------------------------------------------------ | Combine 'LibraryName'. in parsing we prefer value coming--- from munged @name@ field over the @lib-name@.------ /Should/ be irrelevant.-combineLibraryName :: LibraryName -> LibraryName -> LibraryName-combineLibraryName l@(LSubLibName _) _ = l-combineLibraryName _ l                 = l---- To maintain backwards-compatibility, we accept both comma/non-comma--- separated variants of this field.  You SHOULD use the comma syntax if you--- use any new functions, although actually it's unambiguous due to a quirk--- of the fact that modules must start with capital letters.--showExposedModules :: [ExposedModule] -> Disp.Doc-showExposedModules xs-    | all isExposedModule xs = Disp.fsep (map pretty xs)-    | otherwise = Disp.fsep (Disp.punctuate Disp.comma (map pretty xs))-    where isExposedModule (ExposedModule _ Nothing) = True-          isExposedModule _ = False---- | Setter for the @package-name@ field.  It should be acceptable for this--- to be a no-op.-setMaybePackageName :: Maybe PackageName -> InstalledPackageInfo -> InstalledPackageInfo-setMaybePackageName Nothing   ipi = ipi-setMaybePackageName (Just pn) ipi = ipi-    { sourcePackageId = (sourcePackageId ipi) {pkgName=pn}-    }--setMungedPackageName :: MungedPackageName -> InstalledPackageInfo -> InstalledPackageInfo-setMungedPackageName (MungedPackageName pn ln) ipi = ipi-    { sourcePackageId = (sourcePackageId ipi) {pkgName=pn}-    , sourceLibName   = ln-    }----- | Returns @Just@ if the @name@ field of the IPI record would not contain---- the package name verbatim.  This helps us avoid writing @package-name@---- when it's redundant.-maybePackageName :: InstalledPackageInfo -> Maybe PackageName-maybePackageName ipi = case sourceLibName ipi of-    LMainLibName  -> Nothing-    LSubLibName _ -> Just (packageName ipi)------------------------------------------------------------------------------------ Auxiliary types----------------------------------------------------------------------------------newtype ExposedModules = ExposedModules { getExposedModules :: [ExposedModule] }--instance Newtype [ExposedModule] ExposedModules--instance Parsec ExposedModules where-    parsec = ExposedModules <$> parsecOptCommaList parsec--instance Pretty ExposedModules where-    pretty = showExposedModules . getExposedModules--newtype CompatPackageKey = CompatPackageKey { getCompatPackageKey :: String }--instance Newtype String CompatPackageKey--instance Pretty CompatPackageKey where-    pretty = Disp.text . getCompatPackageKey--instance Parsec CompatPackageKey where-    parsec = CompatPackageKey <$> P.munch1 uid_char where-        uid_char c = Char.isAlphaNum c || c `elem` ("-_.=[],:<>+" :: String)--newtype InstWith = InstWith { getInstWith :: [(ModuleName,OpenModule)] }--instance Newtype  [(ModuleName, OpenModule)] InstWith--instance Pretty InstWith where-    pretty = dispOpenModuleSubst . Map.fromList . getInstWith--instance Parsec InstWith where-    parsec = InstWith . Map.toList <$> parsecOpenModuleSubst---- | SPDX License expression or legacy license. Lenient parser, accepts either.-newtype SpecLicenseLenient = SpecLicenseLenient { getSpecLicenseLenient :: Either SPDX.License License }--instance Newtype (Either SPDX.License License) SpecLicenseLenient--instance Parsec SpecLicenseLenient where-    parsec = fmap SpecLicenseLenient $ Left <$> P.try parsec <|> Right <$> parsec--instance Pretty SpecLicenseLenient where-    pretty = either pretty pretty . getSpecLicenseLenient------------------------------------------------------------------------------------ Basic fields------------------------------------------------------------------------------------ | This type is used to mangle fields as--- in serialised textual representation--- to the actual 'InstalledPackageInfo' fields.-data Basic = Basic-    { _basicName          :: MungedPackageName-    , _basicVersion       :: Version-    , _basicPkgName       :: Maybe PackageName-    , _basicLibName       :: LibraryName-    , _basicLibVisibility :: LibraryVisibility-    }--basic :: Lens' InstalledPackageInfo Basic-basic f ipi = g <$> f b-  where-    b = Basic-        (mungedPackageName ipi)-        (packageVersion ipi)-        (maybePackageName ipi)-        (sourceLibName ipi)-        (libVisibility ipi)--    g (Basic n v pn ln lv) = ipi-        & setMungedPackageName n-        & L.sourcePackageId . L.pkgVersion .~ v-        & setMaybePackageName pn-        & L.sourceLibName .~ ln-        & L.libVisibility .~ lv--basicName :: Lens' Basic MungedPackageName-basicName f b = (\x -> b { _basicName = x }) <$> f (_basicName b)-{-# INLINE basicName #-}--basicVersion :: Lens' Basic Version-basicVersion f b = (\x -> b { _basicVersion = x }) <$> f (_basicVersion b)-{-# INLINE basicVersion #-}--basicPkgName :: Lens' Basic (Maybe PackageName)-basicPkgName f b = (\x -> b { _basicPkgName = x }) <$> f (_basicPkgName b)-{-# INLINE basicPkgName #-}--basicLibName :: Lens' Basic (Maybe UnqualComponentName)-basicLibName f b = (\x -> b { _basicLibName = maybeToLibraryName x }) <$>-    f (libraryNameString (_basicLibName b))-{-# INLINE basicLibName #-}--basicLibVisibility :: Lens' Basic LibraryVisibility-basicLibVisibility f b = (\x -> b { _basicLibVisibility = x }) <$>-    f (_basicLibVisibility b)-{-# INLINE basicLibVisibility #-}--basicFieldGrammar-    :: ( FieldGrammar c g, Applicative (g Basic)-       , c (Identity LibraryVisibility)-       , c (Identity PackageName)-       , c (Identity UnqualComponentName)-       , c (MQuoted MungedPackageName)-       , c (MQuoted Version)-       )-    => g Basic Basic-basicFieldGrammar = mkBasic-    <$> optionalFieldDefAla "name"          MQuoted  basicName (mungedPackageName emptyInstalledPackageInfo)-    <*> optionalFieldDefAla "version"       MQuoted  basicVersion nullVersion-    <*> optionalField       "package-name"           basicPkgName-    <*> optionalField       "lib-name"               basicLibName-    <*> optionalFieldDef    "visibility"             basicLibVisibility LibraryVisibilityPrivate-  where-    mkBasic n v pn ln lv = Basic n v pn ln' lv'-      where-        ln' = maybe LMainLibName LSubLibName ln-        -- Older GHCs (<8.8) always report installed libraries as private-        -- because their ghc-pkg builds with an older Cabal.-        -- So we always set LibraryVisibilityPublic for main (unnamed) libs.-        -- This can be removed once we stop supporting GHC<8.8, at the-        -- condition that we keep marking main libraries as public when-        -- registering them.-        lv' = if-                let MungedPackageName _ mln = n in-                -- We need to check both because on ghc<8.2 ln' will always-                -- be LMainLibName-                ln' == LMainLibName && mln == LMainLibName-              then LibraryVisibilityPublic-              else lv
− src/Distribution/Types/InstalledPackageInfo/Lens.hs 
@@ -1,190 +0,0 @@-module Distribution.Types.InstalledPackageInfo.Lens (-    InstalledPackageInfo,-    module Distribution.Types.InstalledPackageInfo.Lens-    ) where--import Distribution.Compat.Lens-import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Backpack                   (OpenModule)-import Distribution.License                    (License)-import Distribution.ModuleName                 (ModuleName)-import Distribution.Package                    (AbiHash, ComponentId, PackageIdentifier, UnitId)-import Distribution.Types.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo)-import Distribution.Types.LibraryName          (LibraryName)-import Distribution.Types.LibraryVisibility    (LibraryVisibility)-import Distribution.Utils.ShortText            (ShortText)---import qualified Distribution.SPDX                       as SPDX-import qualified Distribution.Types.InstalledPackageInfo as T--sourcePackageId :: Lens' InstalledPackageInfo PackageIdentifier-sourcePackageId f s = fmap (\x -> s { T.sourcePackageId = x }) (f (T.sourcePackageId s))-{-# INLINE sourcePackageId #-}--installedUnitId :: Lens' InstalledPackageInfo UnitId-installedUnitId f s = fmap (\x -> s { T.installedUnitId = x }) (f (T.installedUnitId s))-{-# INLINE installedUnitId #-}--installedComponentId_ :: Lens' InstalledPackageInfo ComponentId-installedComponentId_ f s = fmap (\x -> s { T.installedComponentId_ = x }) (f (T.installedComponentId_ s))-{-# INLINE installedComponentId_ #-}--instantiatedWith :: Lens' InstalledPackageInfo [(ModuleName,OpenModule)]-instantiatedWith f s = fmap (\x -> s { T.instantiatedWith = x }) (f (T.instantiatedWith s))-{-# INLINE instantiatedWith #-}--sourceLibName :: Lens' InstalledPackageInfo LibraryName-sourceLibName f s = fmap (\x -> s { T.sourceLibName = x }) (f (T.sourceLibName s))-{-# INLINE sourceLibName #-}--compatPackageKey :: Lens' InstalledPackageInfo String-compatPackageKey f s = fmap (\x -> s { T.compatPackageKey = x }) (f (T.compatPackageKey s))-{-# INLINE compatPackageKey #-}--license :: Lens' InstalledPackageInfo (Either SPDX.License License)-license f s = fmap (\x -> s { T.license = x }) (f (T.license s))-{-# INLINE license #-}--copyright :: Lens' InstalledPackageInfo ShortText-copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s))-{-# INLINE copyright #-}--maintainer :: Lens' InstalledPackageInfo ShortText-maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s))-{-# INLINE maintainer #-}--author :: Lens' InstalledPackageInfo ShortText-author f s = fmap (\x -> s { T.author = x }) (f (T.author s))-{-# INLINE author #-}--stability :: Lens' InstalledPackageInfo ShortText-stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s))-{-# INLINE stability #-}--homepage :: Lens' InstalledPackageInfo ShortText-homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s))-{-# INLINE homepage #-}--pkgUrl :: Lens' InstalledPackageInfo ShortText-pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s))-{-# INLINE pkgUrl #-}--synopsis :: Lens' InstalledPackageInfo ShortText-synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s))-{-# INLINE synopsis #-}--description :: Lens' InstalledPackageInfo ShortText-description f s = fmap (\x -> s { T.description = x }) (f (T.description s))-{-# INLINE description #-}--category :: Lens' InstalledPackageInfo ShortText-category f s = fmap (\x -> s { T.category = x }) (f (T.category s))-{-# INLINE category #-}--abiHash :: Lens' InstalledPackageInfo AbiHash-abiHash f s = fmap (\x -> s { T.abiHash = x }) (f (T.abiHash s))-{-# INLINE abiHash #-}--indefinite :: Lens' InstalledPackageInfo Bool-indefinite f s = fmap (\x -> s { T.indefinite = x }) (f (T.indefinite s))-{-# INLINE indefinite #-}--exposed :: Lens' InstalledPackageInfo Bool-exposed f s = fmap (\x -> s { T.exposed = x }) (f (T.exposed s))-{-# INLINE exposed #-}--exposedModules :: Lens' InstalledPackageInfo [ExposedModule]-exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s))-{-# INLINE exposedModules #-}--hiddenModules :: Lens' InstalledPackageInfo [ModuleName]-hiddenModules f s = fmap (\x -> s { T.hiddenModules = x }) (f (T.hiddenModules s))-{-# INLINE hiddenModules #-}--trusted :: Lens' InstalledPackageInfo Bool-trusted f s = fmap (\x -> s { T.trusted = x }) (f (T.trusted s))-{-# INLINE trusted #-}--importDirs :: Lens' InstalledPackageInfo [FilePath]-importDirs f s = fmap (\x -> s { T.importDirs = x }) (f (T.importDirs s))-{-# INLINE importDirs #-}--libraryDirs :: Lens' InstalledPackageInfo [FilePath]-libraryDirs f s = fmap (\x -> s { T.libraryDirs = x }) (f (T.libraryDirs s))-{-# INLINE libraryDirs #-}--libraryDynDirs :: Lens' InstalledPackageInfo [FilePath]-libraryDynDirs f s = fmap (\x -> s { T.libraryDynDirs = x }) (f (T.libraryDynDirs s))-{-# INLINE libraryDynDirs #-}--dataDir :: Lens' InstalledPackageInfo FilePath-dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s))-{-# INLINE dataDir #-}--hsLibraries :: Lens' InstalledPackageInfo [String]-hsLibraries f s = fmap (\x -> s { T.hsLibraries = x }) (f (T.hsLibraries s))-{-# INLINE hsLibraries #-}--extraLibraries :: Lens' InstalledPackageInfo [String]-extraLibraries f s = fmap (\x -> s { T.extraLibraries = x }) (f (T.extraLibraries s))-{-# INLINE extraLibraries #-}--extraGHCiLibraries :: Lens' InstalledPackageInfo [String]-extraGHCiLibraries f s = fmap (\x -> s { T.extraGHCiLibraries = x }) (f (T.extraGHCiLibraries s))-{-# INLINE extraGHCiLibraries #-}--includeDirs :: Lens' InstalledPackageInfo [FilePath]-includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s))-{-# INLINE includeDirs #-}--includes :: Lens' InstalledPackageInfo [String]-includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s))-{-# INLINE includes #-}--depends :: Lens' InstalledPackageInfo [UnitId]-depends f s = fmap (\x -> s { T.depends = x }) (f (T.depends s))-{-# INLINE depends #-}--abiDepends :: Lens' InstalledPackageInfo [AbiDependency]-abiDepends f s = fmap (\x -> s { T.abiDepends = x }) (f (T.abiDepends s))-{-# INLINE abiDepends #-}--ccOptions :: Lens' InstalledPackageInfo [String]-ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s))-{-# INLINE ccOptions #-}--cxxOptions :: Lens' InstalledPackageInfo [String]-cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s))-{-# INLINE cxxOptions #-}--ldOptions :: Lens' InstalledPackageInfo [String]-ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s))-{-# INLINE ldOptions #-}--frameworkDirs :: Lens' InstalledPackageInfo [FilePath]-frameworkDirs f s = fmap (\x -> s { T.frameworkDirs = x }) (f (T.frameworkDirs s))-{-# INLINE frameworkDirs #-}--frameworks :: Lens' InstalledPackageInfo [String]-frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s))-{-# INLINE frameworks #-}--haddockInterfaces :: Lens' InstalledPackageInfo [FilePath]-haddockInterfaces f s = fmap (\x -> s { T.haddockInterfaces = x }) (f (T.haddockInterfaces s))-{-# INLINE haddockInterfaces #-}--haddockHTMLs :: Lens' InstalledPackageInfo [FilePath]-haddockHTMLs f s = fmap (\x -> s { T.haddockHTMLs = x }) (f (T.haddockHTMLs s))-{-# INLINE haddockHTMLs #-}--pkgRoot :: Lens' InstalledPackageInfo (Maybe FilePath)-pkgRoot f s = fmap (\x -> s { T.pkgRoot = x }) (f (T.pkgRoot s))-{-# INLINE pkgRoot #-}--libVisibility :: Lens' InstalledPackageInfo LibraryVisibility-libVisibility f s = fmap (\x -> s { T.libVisibility = x }) (f (T.libVisibility s))-{-# INLINE libVisibility #-}-
− src/Distribution/Types/LegacyExeDependency.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.Types.LegacyExeDependency-  ( LegacyExeDependency(..)-  ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty-import Distribution.Version (VersionRange, anyVersion)--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp---- | Describes a legacy `build-tools`-style dependency on an executable------ It is "legacy" because we do not know what the build-tool referred to. It--- could refer to a pkg-config executable (PkgconfigName), or an internal--- executable (UnqualComponentName). Thus the name is stringly typed.------ @since 2.0.0.2-data LegacyExeDependency = LegacyExeDependency-                           String-                           VersionRange-                         deriving (Generic, Read, Show, Eq, Typeable, Data)--instance Binary LegacyExeDependency-instance Structured LegacyExeDependency-instance NFData LegacyExeDependency where rnf = genericRnf--instance Pretty LegacyExeDependency where-    pretty (LegacyExeDependency name ver) =-        Disp.text name <+> pretty ver--instance Parsec LegacyExeDependency where-    parsec = do-        name <- parsecMaybeQuoted nameP-        P.spaces-        verRange <- parsecMaybeQuoted parsec <|> pure anyVersion-        pure $ LegacyExeDependency name verRange-      where-        nameP = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-')-        component = do-            cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_')-            if all isDigit cs then fail "invalid component" else return cs
− src/Distribution/Types/Lens.hs 
@@ -1,25 +0,0 @@-module Distribution.Types.Lens (-    module Distribution.Types.Benchmark.Lens,-    module Distribution.Types.BuildInfo.Lens,-    module Distribution.Types.Executable.Lens,-    module Distribution.Types.ForeignLib.Lens,-    module Distribution.Types.GenericPackageDescription.Lens,-    module Distribution.Types.Library.Lens,-    module Distribution.Types.PackageDescription.Lens,-    module Distribution.Types.PackageId.Lens,-    module Distribution.Types.SetupBuildInfo.Lens,-    module Distribution.Types.SourceRepo.Lens,-    module Distribution.Types.TestSuite.Lens,-    ) where--import Distribution.Types.Benchmark.Lens-import Distribution.Types.BuildInfo.Lens-import Distribution.Types.Executable.Lens-import Distribution.Types.ForeignLib.Lens-import Distribution.Types.GenericPackageDescription.Lens-import Distribution.Types.Library.Lens-import Distribution.Types.PackageDescription.Lens-import Distribution.Types.PackageId.Lens-import Distribution.Types.SetupBuildInfo.Lens-import Distribution.Types.SourceRepo.Lens-import Distribution.Types.TestSuite.Lens
− src/Distribution/Types/Library.hs 
@@ -1,96 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}--module Distribution.Types.Library (-    Library(..),-    emptyLibrary,-    explicitLibModules,-    libModulesAutogen,-) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.ModuleName-import Distribution.Types.BuildInfo-import Distribution.Types.LibraryVisibility-import Distribution.Types.ModuleReexport-import Distribution.Types.LibraryName--import qualified Distribution.Types.BuildInfo.Lens as L--data Library = Library-    { libName           :: LibraryName-    , exposedModules    :: [ModuleName]-    , reexportedModules :: [ModuleReexport]-    , signatures        :: [ModuleName]       -- ^ What sigs need implementations?-    , libExposed        :: Bool               -- ^ Is the lib to be exposed by default? (i.e. whether its modules available in GHCi for example)-    , libVisibility     :: LibraryVisibility  -- ^ Whether this multilib can be dependent from outside.-    , libBuildInfo      :: BuildInfo-    }-    deriving (Generic, Show, Eq, Read, Typeable, Data)--instance L.HasBuildInfo Library where-    buildInfo f l = (\x -> l { libBuildInfo = x }) <$> f (libBuildInfo l)--instance Binary Library-instance Structured Library-instance NFData Library where rnf = genericRnf--emptyLibrary :: Library-emptyLibrary = Library-    { libName           = LMainLibName-    , exposedModules    = mempty-    , reexportedModules = mempty-    , signatures        = mempty-    , libExposed        = True-    , libVisibility     = mempty-    , libBuildInfo      = mempty-    }---- | This instance is not good.------ We need it for 'PackageDescription.Configuration.addBuildableCondition'.--- More correct method would be some kind of "create empty clone".------ More concretely, 'addBuildableCondition' will make `libVisibility = False`--- libraries when `buildable: false`. This may cause problems.----instance Monoid Library where-    mempty = emptyLibrary-    mappend = (<>)--instance Semigroup Library where-  a <> b = Library-    { libName           = combineLibraryName (libName a) (libName b)-    , exposedModules    = combine exposedModules-    , reexportedModules = combine reexportedModules-    , signatures        = combine signatures-    , libExposed        = libExposed a && libExposed b -- so False propagates-    , libVisibility     = combine libVisibility-    , libBuildInfo      = combine libBuildInfo-    }-    where combine field = field a `mappend` field b---- | Get all the module names from the library (exposed and internal modules)--- which are explicitly listed in the package description which would--- need to be compiled.  (This does not include reexports, which--- do not need to be compiled.)  This may not include all modules for which--- GHC generated interface files (i.e., implicit modules.)-explicitLibModules :: Library -> [ModuleName]-explicitLibModules lib = exposedModules lib-              ++ otherModules (libBuildInfo lib)-              ++ signatures lib---- | Get all the auto generated module names from the library, exposed or not.--- This are a subset of 'libModules'.-libModulesAutogen :: Library -> [ModuleName]-libModulesAutogen lib = autogenModules (libBuildInfo lib)---- | Combine 'LibraryName'. in parsing we prefer value coming--- from munged @name@ field over the @lib-name@.------ /Should/ be irrelevant.-combineLibraryName :: LibraryName -> LibraryName -> LibraryName-combineLibraryName l@(LSubLibName _) _ = l-combineLibraryName _ l                 = l
− src/Distribution/Types/Library/Lens.hs 
@@ -1,45 +0,0 @@-module Distribution.Types.Library.Lens (-    Library,-    module Distribution.Types.Library.Lens,-    ) where--import Distribution.Compat.Lens-import Distribution.Compat.Prelude-import Prelude ()--import Distribution.ModuleName              (ModuleName)-import Distribution.Types.BuildInfo         (BuildInfo)-import Distribution.Types.Library           (Library)-import Distribution.Types.LibraryName       (LibraryName)-import Distribution.Types.LibraryVisibility (LibraryVisibility)-import Distribution.Types.ModuleReexport    (ModuleReexport)--import qualified Distribution.Types.Library as T--libName :: Lens' Library LibraryName-libName f s = fmap (\x -> s { T.libName = x }) (f (T.libName s))-{-# INLINE libName #-}--exposedModules :: Lens' Library [ModuleName]-exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s))-{-# INLINE exposedModules #-}--reexportedModules :: Lens' Library [ModuleReexport]-reexportedModules f s = fmap (\x -> s { T.reexportedModules = x }) (f (T.reexportedModules s))-{-# INLINE reexportedModules #-}--signatures :: Lens' Library [ModuleName]-signatures f s = fmap (\x -> s { T.signatures = x }) (f (T.signatures s))-{-# INLINE signatures #-}--libExposed :: Lens' Library Bool-libExposed f s = fmap (\x -> s { T.libExposed = x }) (f (T.libExposed s))-{-# INLINE libExposed #-}--libVisibility :: Lens' Library LibraryVisibility-libVisibility f s = fmap (\x -> s { T.libVisibility = x }) (f (T.libVisibility s))-{-# INLINE libVisibility #-}--libBuildInfo :: Lens' Library BuildInfo-libBuildInfo f s = fmap (\x -> s { T.libBuildInfo = x }) (f (T.libBuildInfo s))-{-# INLINE libBuildInfo #-}
− src/Distribution/Types/LibraryName.hs 
@@ -1,73 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Distribution.Types.LibraryName (-  LibraryName(..),-  defaultLibName,-  maybeToLibraryName,-  showLibraryName,-  libraryNameStanza,-  libraryNameString,-  -- * Pretty & Parse-  prettyLibraryNameComponent,-  parsecLibraryNameComponent,-  ) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Types.UnqualComponentName-import Distribution.Pretty-import Distribution.Parsec--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp--data LibraryName = LMainLibName-                 | LSubLibName UnqualComponentName-                 deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)--instance Binary LibraryName-instance Structured LibraryName-instance NFData LibraryName where rnf = genericRnf---- | Pretty print 'LibraryName' in build-target-ish syntax.------ /Note:/ there are no 'Pretty' or 'Parsec' instances,--- as there's other way to represent 'LibraryName', namely as bare--- 'UnqualComponentName'. -prettyLibraryNameComponent :: LibraryName -> Disp.Doc-prettyLibraryNameComponent LMainLibName      = Disp.text "lib"-prettyLibraryNameComponent (LSubLibName str) = Disp.text "lib:" <<>> pretty str--parsecLibraryNameComponent :: CabalParsing m => m LibraryName-parsecLibraryNameComponent = do-    _ <- P.string "lib"-    parseComposite <|> parseSingle-  where-    parseSingle = return LMainLibName-    parseComposite = do-        _ <- P.char ':'-        LSubLibName <$> parsec--defaultLibName :: LibraryName-defaultLibName = LMainLibName--showLibraryName :: LibraryName -> String-showLibraryName LMainLibName       = "library"-showLibraryName (LSubLibName name) = "library '" ++ prettyShow name ++ "'"--libraryNameStanza :: LibraryName -> String-libraryNameStanza LMainLibName       = "library"-libraryNameStanza (LSubLibName name) = "library " ++ prettyShow name--libraryNameString :: LibraryName -> Maybe UnqualComponentName-libraryNameString LMainLibName = Nothing-libraryNameString (LSubLibName n) = Just n---- | Convert the 'UnqualComponentName' of a library into a--- 'LibraryName'.-maybeToLibraryName :: Maybe UnqualComponentName -> LibraryName-maybeToLibraryName Nothing = LMainLibName-maybeToLibraryName (Just n) = LSubLibName n-
− src/Distribution/Types/LibraryVisibility.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE OverloadedStrings  #-}--module Distribution.Types.LibraryVisibility(-    LibraryVisibility(..),-) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp---- | Multi-lib visibility------ @since 3.0.0.0----data LibraryVisibility-      -- | Can be depenendent from other packages-    = LibraryVisibilityPublic-      -- | Internal library, default-    | LibraryVisibilityPrivate-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Pretty LibraryVisibility where-    pretty LibraryVisibilityPublic  = Disp.text "public"-    pretty LibraryVisibilityPrivate = Disp.text "private"--instance Parsec LibraryVisibility where-  parsec = do-    name <- P.munch1 isAlpha-    parsecWarning PWTExperimental "visibility is experimental feature (issue #5660)"-    case name of-      "public"  -> return LibraryVisibilityPublic-      "private" -> return LibraryVisibilityPrivate-      _         -> fail $ "Unknown visibility: " ++ name--instance Binary LibraryVisibility-instance Structured LibraryVisibility-instance NFData LibraryVisibility where rnf = genericRnf--instance Semigroup LibraryVisibility where-    LibraryVisibilityPrivate <> LibraryVisibilityPrivate = LibraryVisibilityPrivate-    _                        <> _                        = LibraryVisibilityPublic--instance Monoid LibraryVisibility where-    mempty  = LibraryVisibilityPrivate-    mappend = (<>)
+ src/Distribution/Types/LocalBuildConfig.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module Distribution.Types.LocalBuildConfig+  ( -- * The types+    PackageBuildDescr (..)+  , ComponentBuildDescr (..)+  , LocalBuildDescr (..)+  , LocalBuildConfig (..)+  , BuildOptions (..)++    -- * Conversion functions+  , buildOptionsConfigFlags+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.GivenComponent+import Distribution.Types.PackageDescription+import Distribution.Types.UnitId++import Distribution.PackageDescription+import Distribution.Simple.Compiler+import Distribution.Simple.Flag+import Distribution.Simple.InstallDirs hiding+  ( absoluteInstallDirs+  , prefixRelativeInstallDirs+  , substPathTemplate+  )+import Distribution.Simple.PackageIndex+import Distribution.Simple.Program.Db (ProgramDb)+import Distribution.Simple.Setup.Config+import Distribution.System+import Distribution.Utils.Path++import Distribution.Compat.Graph (Graph)++-- | 'PackageBuildDescr' contains the information Cabal determines after+-- performing package-wide configuration of a package, before doing any+-- per-component configuration.+data PackageBuildDescr = PackageBuildDescr+  { configFlags :: ConfigFlags+  -- ^ Options passed to the configuration step.+  -- Needed to re-run configuration when .cabal is out of date+  , flagAssignment :: FlagAssignment+  -- ^ The final set of flags which were picked for this package+  , componentEnabledSpec :: ComponentRequestedSpec+  -- ^ What components were enabled during configuration, and why.+  , compiler :: Compiler+  -- ^ The compiler we're building with+  , hostPlatform :: Platform+  -- ^ The platform we're building for+  , pkgDescrFile :: Maybe (SymbolicPath Pkg File)+  -- ^ the filename containing the .cabal file, if available+  , localPkgDescr :: PackageDescription+  -- ^ WARNING WARNING WARNING Be VERY careful about using+  -- this function; we haven't deprecated it but using it+  -- could introduce subtle bugs related to+  -- 'HookedBuildInfo'.+  --+  -- In principle, this is supposed to contain the+  -- resolved package description, that does not contain+  -- any conditionals.  However, it MAY NOT contain+  -- the description with a 'HookedBuildInfo' applied+  -- to it; see 'HookedBuildInfo' for the whole sordid saga.+  -- As much as possible, Cabal library should avoid using+  -- this parameter.+  , installDirTemplates :: InstallDirTemplates+  -- ^ The installation directories for the various different+  -- kinds of files+  -- TODO: inplaceDirTemplates :: InstallDirs FilePath+  , withPackageDB :: PackageDBStack+  -- ^ What package database to use, global\/user+  , extraCoverageFor :: [UnitId]+  -- ^ For per-package builds-only: an extra list of libraries to be included in+  -- the hpc coverage report for testsuites run with @--enable-coverage@.+  -- Notably, this list must exclude indefinite libraries and instantiations+  -- because HPC does not support backpack (Nov. 2023).+  }+  deriving (Generic, Read, Show)++-- | Information about individual components in a package,+-- determined after the configure step.+data ComponentBuildDescr = ComponentBuildDescr+  { componentGraph :: Graph ComponentLocalBuildInfo+  -- ^ All the components to build, ordered by topological+  -- sort, and with their INTERNAL dependencies over the+  -- intrapackage dependency graph.+  -- TODO: this is assumed to be short; otherwise we want+  -- some sort of ordered map.+  , componentNameMap :: Map ComponentName [ComponentLocalBuildInfo]+  -- ^ A map from component name to all matching+  -- components.  These coincide with 'componentGraph'+  -- There may be more than one matching component because of backpack instantiations+  , promisedPkgs :: Map (PackageName, ComponentName) PromisedComponent+  -- ^ The packages we were promised, but aren't already installed.+  -- MP: Perhaps this just needs to be a Set UnitId at this stage.+  , installedPkgs :: InstalledPackageIndex+  -- ^ All the info about the installed packages that the+  -- current package depends on (directly or indirectly).+  -- The copy saved on disk does NOT include internal+  -- dependencies (because we just don't have enough+  -- information at this point to have an+  -- 'InstalledPackageInfo' for an internal dep), but we+  -- will often update it with the internal dependencies;+  -- see for example 'Distribution.Simple.Build.build'.+  -- (This admonition doesn't apply for per-component builds.)+  }+  deriving (Generic, Read, Show)++-- | 'LocalBuildDescr ' contains the information Cabal determines after+-- performing package-wide and per-component configuration of a package.+--+-- This information can no longer be changed after that point.+data LocalBuildDescr = LocalBuildDescr+  { packageBuildDescr :: PackageBuildDescr+  -- ^ Information that is available after configuring the package itself,+  -- before looking at individual components.+  , componentBuildDescr :: ComponentBuildDescr+  -- ^ Information about individual components in the package+  -- determined after the configure step.+  }+  deriving (Generic, Read, Show)++-- | 'LocalBuildConfig' contains options that can be controlled+-- by the user and serve as inputs to the configuration of a package.+data LocalBuildConfig = LocalBuildConfig+  { extraConfigArgs :: [String]+  -- ^ Extra args on the command line for the configuration step.+  -- Needed to re-run configuration when .cabal is out of date+  , withPrograms :: ProgramDb+  -- ^ Location and args for all programs+  , withBuildOptions :: BuildOptions+  -- ^ Options to control the build, e.g. whether to+  -- enable profiling or to enable program coverage.+  }+  deriving (Generic, Read, Show)++-- | 'BuildOptions' contains configuration options that can be controlled+-- by the user.+data BuildOptions = BuildOptions+  { withVanillaLib :: Bool+  -- ^ Whether to build normal libs.+  , withProfLib :: Bool+  -- ^ Whether to build normal libs.+  , withProfLibShared :: Bool+  -- ^ Whether to build profiling versions of libs.+  , withSharedLib :: Bool+  -- ^ Whether to build shared versions of libs.+  , withStaticLib :: Bool+  -- ^ Whether to build static versions of libs (with all other libs rolled in)+  , withDynExe :: Bool+  -- ^ Whether to link executables dynamically+  , withFullyStaticExe :: Bool+  -- ^ Whether to link executables fully statically+  , withProfExe :: Bool+  -- ^ Whether to build executables for profiling.+  , withProfLibDetail :: ProfDetailLevel+  -- ^ Level of automatic profile detail.+  , withProfExeDetail :: ProfDetailLevel+  -- ^ Level of automatic profile detail.+  , withOptimization :: OptimisationLevel+  -- ^ Whether to build with optimization (if available).+  , withDebugInfo :: DebugInfoLevel+  -- ^ Whether to emit debug info (if available).+  , withGHCiLib :: Bool+  -- ^ Whether to build libs suitable for use with GHCi.+  , splitSections :: Bool+  -- ^ Use -split-sections with GHC, if available+  , splitObjs :: Bool+  -- ^ Use -split-objs with GHC, if available+  , stripExes :: Bool+  -- ^ Whether to strip executables during install+  , stripLibs :: Bool+  -- ^ Whether to strip libraries during install+  , exeCoverage :: Bool+  -- ^ Whether to enable executable program coverage+  , libCoverage :: Bool+  -- ^ Whether to enable library program coverage+  , relocatable :: Bool+  -- ^ Whether to build a relocatable package+  }+  deriving (Eq, Generic, Read, Show)++instance Binary PackageBuildDescr+instance Structured PackageBuildDescr+instance Binary ComponentBuildDescr+instance Structured ComponentBuildDescr+instance Binary LocalBuildDescr+instance Structured LocalBuildDescr+instance Binary LocalBuildConfig+instance Structured LocalBuildConfig+instance Binary BuildOptions+instance Structured BuildOptions++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+    , 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+    , configLibCoverage = mempty+    , configRelocatable = toFlag $ relocatable+    , configOptimization = toFlag $ withOptimization+    , configSplitSections = toFlag $ splitSections+    , configSplitObjs = toFlag $ splitObjs+    , configStripExes = toFlag $ stripExes+    , configStripLibs = toFlag $ stripLibs+    , configDebugInfo = toFlag $ withDebugInfo+    }
src/Distribution/Types/LocalBuildInfo.hs view
@@ -1,170 +1,322 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -module Distribution.Types.LocalBuildInfo (-    -- * The type--    LocalBuildInfo(..),+module Distribution.Types.LocalBuildInfo+  ( -- * The types+    LocalBuildInfo+      ( LocalBuildInfo+      , configFlags+      , flagAssignment+      , componentEnabledSpec+      , extraConfigArgs+      , installDirTemplates+      , compiler+      , hostPlatform+      , pkgDescrFile+      , componentGraph+      , componentNameMap+      , promisedPkgs+      , installedPkgs+      , localPkgDescr+      , withPrograms+      , withPackageDB+      , withVanillaLib+      , withProfLib+      , withProfLibShared+      , withDynExe+      , withFullyStaticExe+      , withProfExe+      , withSharedLib+      , withStaticLib+      , withProfLibDetail+      , withProfExeDetail+      , withOptimization+      , withDebugInfo+      , withGHCiLib+      , splitSections+      , splitObjs+      , stripExes+      , stripLibs+      , exeCoverage+      , libCoverage+      , extraCoverageFor+      , relocatable+      , ..+      )      -- * Convenience accessors--    localComponentId,-    localUnitId,-    localCompatPackageKey,-    localPackage,+  , localComponentId+  , localUnitId+  , localCompatPackageKey+  , localPackage+  , buildDir+  , buildDirPBD+  , setupFlagsBuildDir+  , distPrefLBI+  , packageRoot+  , progPrefix+  , progSuffix      -- * Build targets of the 'LocalBuildInfo'.--    componentNameCLBIs,--    -- NB: the primes mean that they take a 'PackageDescription'-    -- which may not match 'localPkgDescr' in 'LocalBuildInfo'.-    -- More logical types would drop this argument, but-    -- at the moment, this is the ONLY supported function, because-    -- 'localPkgDescr' is not guaranteed to match.  At some point-    -- we will fix it and then we can use the (free) unprimed-    -- namespace for the correct commands.-    ---    -- See https://github.com/haskell/cabal/issues/3606 for more-    -- details.+  , componentNameCLBIs+  -- NB: the primes mean that they take a 'PackageDescription'+  -- which may not match 'localPkgDescr' in 'LocalBuildInfo'.+  -- More logical types would drop this argument, but+  -- at the moment, this is the ONLY supported function, because+  -- 'localPkgDescr' is not guaranteed to match.  At some point+  -- we will fix it and then we can use the (free) unprimed+  -- namespace for the correct commands.+  --+  -- See https://github.com/haskell/cabal/issues/3606 for more+  -- details. -    componentNameTargets',-    unitIdTarget',-    allTargetsInBuildOrder',-    withAllTargetsInBuildOrder',-    neededTargetsInBuildOrder',-    withNeededTargetsInBuildOrder',-    testCoverage,+  , componentNameTargets'+  , unitIdTarget'+  , allTargetsInBuildOrder'+  , withAllTargetsInBuildOrder'+  , neededTargetsInBuildOrder'+  , withNeededTargetsInBuildOrder'+  , testCoverage+  , buildWays      -- * Functions you SHOULD NOT USE (yet), but are defined here to-    -- prevent someone from accidentally defining them -    componentNameTargets,-    unitIdTarget,-    allTargetsInBuildOrder,-    withAllTargetsInBuildOrder,-    neededTargetsInBuildOrder,-    withNeededTargetsInBuildOrder,+  -- prevent someone from accidentally defining them++  , componentNameTargets+  , unitIdTarget+  , allTargetsInBuildOrder+  , withAllTargetsInBuildOrder+  , neededTargetsInBuildOrder+  , withNeededTargetsInBuildOrder   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Types.PackageDescription+import Distribution.Types.ComponentId import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.ComponentRequestedSpec-import Distribution.Types.ComponentId+import Distribution.Types.GivenComponent+import qualified Distribution.Types.LocalBuildConfig as LBC+import Distribution.Types.PackageDescription import Distribution.Types.PackageId-import Distribution.Types.UnitId import Distribution.Types.TargetInfo+import Distribution.Types.UnitId -import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs,-                                               prefixRelativeInstallDirs,-                                               substPathTemplate, )-import Distribution.Simple.Program+import Distribution.Utils.Path+ import Distribution.PackageDescription+import Distribution.Pretty+import Distribution.Simple.BuildWay import Distribution.Simple.Compiler+import Distribution.Simple.Flag+import Distribution.Simple.InstallDirs hiding+  ( absoluteInstallDirs+  , prefixRelativeInstallDirs+  , substPathTemplate+  ) import Distribution.Simple.PackageIndex-import Distribution.Simple.Setup+import Distribution.Simple.Program+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Config import Distribution.System-import Distribution.Pretty +import qualified Data.Map as Map import Distribution.Compat.Graph (Graph) import qualified Distribution.Compat.Graph as Graph-import qualified Data.Map as Map +import qualified System.FilePath as FilePath (takeDirectory)+ -- | Data cached after configuration step.  See also -- 'Distribution.Simple.Setup.ConfigFlags'.-data LocalBuildInfo = LocalBuildInfo {-        configFlags   :: ConfigFlags,-        -- ^ Options passed to the configuration step.-        -- Needed to re-run configuration when .cabal is out of date-        flagAssignment :: FlagAssignment,-        -- ^ The final set of flags which were picked for this package-        componentEnabledSpec :: ComponentRequestedSpec,-        -- ^ What components were enabled during configuration, and why.-        extraConfigArgs     :: [String],-        -- ^ Extra args on the command line for the configuration step.-        -- Needed to re-run configuration when .cabal is out of date-        installDirTemplates :: InstallDirTemplates,-                -- ^ The installation directories for the various different-                -- kinds of files-        --TODO: inplaceDirTemplates :: InstallDirs FilePath-        compiler      :: Compiler,-                -- ^ The compiler we're building with-        hostPlatform  :: Platform,-                -- ^ The platform we're building for-        buildDir      :: FilePath,-                -- ^ Where to build the package.-        cabalFilePath :: Maybe FilePath,-                -- ^ Path to the cabal file, if given during configuration.-        componentGraph :: Graph ComponentLocalBuildInfo,-                -- ^ All the components to build, ordered by topological-                -- sort, and with their INTERNAL dependencies over the-                -- intrapackage dependency graph.-                -- TODO: this is assumed to be short; otherwise we want-                -- some sort of ordered map.-        componentNameMap :: Map ComponentName [ComponentLocalBuildInfo],-                -- ^ A map from component name to all matching-                -- components.  These coincide with 'componentGraph'-        installedPkgs :: InstalledPackageIndex,-                -- ^ All the info about the installed packages that the-                -- current package depends on (directly or indirectly).-                -- The copy saved on disk does NOT include internal-                -- dependencies (because we just don't have enough-                -- information at this point to have an-                -- 'InstalledPackageInfo' for an internal dep), but we-                -- will often update it with the internal dependencies;-                -- see for example 'Distribution.Simple.Build.build'.-                -- (This admonition doesn't apply for per-component builds.)-        pkgDescrFile  :: Maybe FilePath,-                -- ^ the filename containing the .cabal file, if available-        localPkgDescr :: PackageDescription,-                -- ^ WARNING WARNING WARNING Be VERY careful about using-                -- this function; we haven't deprecated it but using it-                -- could introduce subtle bugs related to-                -- 'HookedBuildInfo'.-                ---                -- In principle, this is supposed to contain the-                -- resolved package description, that does not contain-                -- any conditionals.  However, it MAY NOT contain-                -- the description with a 'HookedBuildInfo' applied-                -- to it; see 'HookedBuildInfo' for the whole sordid saga.-                -- As much as possible, Cabal library should avoid using-                -- this parameter.-        withPrograms  :: ProgramDb, -- ^Location and args for all programs-        withPackageDB :: PackageDBStack,  -- ^What package database to use, global\/user-        withVanillaLib:: Bool,  -- ^Whether to build normal libs.-        withProfLib   :: Bool,  -- ^Whether to build profiling versions of libs.-        withSharedLib :: Bool,  -- ^Whether to build shared versions of libs.-        withStaticLib :: Bool,  -- ^Whether to build static versions of libs (with all other libs rolled in)-        withDynExe    :: Bool,  -- ^Whether to link executables dynamically-        withFullyStaticExe :: Bool,  -- ^Whether to link executables fully statically-        withProfExe   :: Bool,  -- ^Whether to build executables for profiling.-        withProfLibDetail :: ProfDetailLevel, -- ^Level of automatic profile detail.-        withProfExeDetail :: ProfDetailLevel, -- ^Level of automatic profile detail.-        withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available).-        withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (if available).-        withGHCiLib   :: Bool,  -- ^Whether to build libs suitable for use with GHCi.-        splitSections :: Bool,  -- ^Use -split-sections with GHC, if available-        splitObjs     :: Bool,  -- ^Use -split-objs with GHC, if available-        stripExes     :: Bool,  -- ^Whether to strip executables during install-        stripLibs     :: Bool,  -- ^Whether to strip libraries during install-        exeCoverage :: Bool,  -- ^Whether to enable executable program coverage-        libCoverage :: Bool,  -- ^Whether to enable library program coverage-        progPrefix    :: PathTemplate, -- ^Prefix to be prepended to installed executables-        progSuffix    :: PathTemplate, -- ^Suffix to be appended to installed executables-        relocatable   :: Bool --  ^Whether to build a relocatable package-  } deriving (Generic, Read, Show, Typeable)+data LocalBuildInfo = NewLocalBuildInfo+  { localBuildDescr :: LBC.LocalBuildDescr+  -- ^ Information about a package determined by Cabal+  -- after the configuration step.+  , localBuildConfig :: LBC.LocalBuildConfig+  -- ^ Information about a package configuration+  -- that can be modified by the user at configuration time.+  }+  deriving (Generic, Read, Show) +{-# COMPLETE LocalBuildInfo #-}++-- | This pattern synonym is for backwards compatibility, to adapt+-- to 'LocalBuildInfo' being split into 'LocalBuildDescr' and 'LocalBuildConfig'.+pattern LocalBuildInfo+  :: ConfigFlags+  -> FlagAssignment+  -> ComponentRequestedSpec+  -> [String]+  -> InstallDirTemplates+  -> Compiler+  -> Platform+  -> Maybe (SymbolicPath Pkg File)+  -> Graph ComponentLocalBuildInfo+  -> Map ComponentName [ComponentLocalBuildInfo]+  -> Map (PackageName, ComponentName) PromisedComponent+  -> InstalledPackageIndex+  -> PackageDescription+  -> ProgramDb+  -> PackageDBStack+  -> Bool+  -> Bool+  -> Bool+  -> Bool+  -> Bool+  -> Bool+  -> Bool+  -> Bool+  -> ProfDetailLevel+  -> ProfDetailLevel+  -> OptimisationLevel+  -> DebugInfoLevel+  -> Bool+  -> Bool+  -> Bool+  -> Bool+  -> Bool+  -> Bool+  -> Bool+  -> [UnitId]+  -> Bool+  -> LocalBuildInfo+pattern LocalBuildInfo+  { configFlags+  , flagAssignment+  , componentEnabledSpec+  , extraConfigArgs+  , installDirTemplates+  , compiler+  , hostPlatform+  , pkgDescrFile+  , componentGraph+  , componentNameMap+  , promisedPkgs+  , installedPkgs+  , localPkgDescr+  , withPrograms+  , withPackageDB+  , withVanillaLib+  , withProfLib+  , withProfLibShared+  , withSharedLib+  , withStaticLib+  , withDynExe+  , withFullyStaticExe+  , withProfExe+  , withProfLibDetail+  , withProfExeDetail+  , withOptimization+  , withDebugInfo+  , withGHCiLib+  , splitSections+  , splitObjs+  , stripExes+  , stripLibs+  , exeCoverage+  , libCoverage+  , extraCoverageFor+  , relocatable+  } =+  NewLocalBuildInfo+    { localBuildDescr =+      LBC.LocalBuildDescr+        { packageBuildDescr =+          LBC.PackageBuildDescr+            { configFlags+            , flagAssignment+            , componentEnabledSpec+            , compiler+            , hostPlatform+            , localPkgDescr+            , installDirTemplates+            , withPackageDB+            , pkgDescrFile+            , extraCoverageFor+            }+        , componentBuildDescr =+          LBC.ComponentBuildDescr+            { componentGraph+            , componentNameMap+            , promisedPkgs+            , installedPkgs+            }+        }+    , localBuildConfig =+      LBC.LocalBuildConfig+        { extraConfigArgs+        , withPrograms+        , withBuildOptions =+          LBC.BuildOptions+            { withVanillaLib+            , withProfLib+            , withProfLibShared+            , withSharedLib+            , withStaticLib+            , withDynExe+            , withFullyStaticExe+            , withProfExe+            , withProfLibDetail+            , withProfExeDetail+            , withOptimization+            , withDebugInfo+            , withGHCiLib+            , splitSections+            , splitObjs+            , stripExes+            , stripLibs+            , exeCoverage+            , libCoverage+            , relocatable+            }+        }+    }+ instance Binary LocalBuildInfo instance Structured LocalBuildInfo  ------------------------------------------------------------------------------- -- Accessor functions +buildDir :: LocalBuildInfo -> SymbolicPath Pkg (Dir Build)+buildDir lbi =+  buildDirPBD $ LBC.packageBuildDescr $ localBuildDescr lbi++buildDirPBD :: LBC.PackageBuildDescr -> SymbolicPath Pkg (Dir Build)+buildDirPBD (LBC.PackageBuildDescr{configFlags = cfg}) =+  setupFlagsBuildDir $ configCommonFlags cfg++setupFlagsBuildDir :: CommonSetupFlags -> SymbolicPath Pkg (Dir Build)+setupFlagsBuildDir cfg = fromFlag (setupDistPref cfg) </> makeRelativePathEx "build"++distPrefLBI :: LocalBuildInfo -> SymbolicPath Pkg (Dir Dist)+distPrefLBI = fromFlag . setupDistPref . configCommonFlags . LBC.configFlags . LBC.packageBuildDescr . localBuildDescr++-- | The (relative or absolute) path to the package root, based on+--+--  - the working directory flag+--  - the @.cabal@ path+packageRoot :: CommonSetupFlags -> FilePath+packageRoot cfg =+  case flagToMaybe (setupCabalFilePath cfg) of+    Just cabalPath -> FilePath.takeDirectory $ interpretSymbolicPath mbWorkDir cabalPath+    Nothing -> maybe "." getSymbolicPath mbWorkDir+  where+    mbWorkDir = flagToMaybe $ setupWorkingDir cfg++progPrefix, progSuffix :: LocalBuildInfo -> PathTemplate+progPrefix (LocalBuildInfo{configFlags = cfg}) =+  fromFlag $ configProgPrefix cfg+progSuffix (LocalBuildInfo{configFlags = cfg}) =+  fromFlag $ configProgSuffix cfg+ -- TODO: Get rid of these functions, as much as possible.  They are -- a bit useful in some cases, but you should be very careful! @@ -173,71 +325,73 @@ -- on the package ID. localComponentId :: LocalBuildInfo -> ComponentId localComponentId lbi =-    case componentNameCLBIs lbi (CLibName LMainLibName) of-        [LibComponentLocalBuildInfo { componentComponentId = cid }]-          -> cid-        _ -> mkComponentId (prettyShow (localPackage lbi))+  case componentNameCLBIs lbi (CLibName LMainLibName) of+    [LibComponentLocalBuildInfo{componentComponentId = cid}] ->+      cid+    _ -> mkComponentId (prettyShow (localPackage lbi))  -- | Extract the 'PackageIdentifier' of a 'LocalBuildInfo'. -- This is a "safe" use of 'localPkgDescr' localPackage :: LocalBuildInfo -> PackageId-localPackage lbi = package (localPkgDescr lbi)+localPackage (LocalBuildInfo{localPkgDescr = pkg}) = package pkg  -- | Extract the 'UnitId' from the library component of a -- 'LocalBuildInfo' if it exists, or make a fake unit ID based on -- the package ID. localUnitId :: LocalBuildInfo -> UnitId localUnitId lbi =-    case componentNameCLBIs lbi (CLibName LMainLibName) of-        [LibComponentLocalBuildInfo { componentUnitId = uid }]-          -> uid-        _ -> mkLegacyUnitId $ localPackage lbi+  case componentNameCLBIs lbi (CLibName LMainLibName) of+    [LibComponentLocalBuildInfo{componentUnitId = uid}] ->+      uid+    _ -> mkLegacyUnitId $ localPackage lbi  -- | Extract the compatibility package key from the public library component of a -- 'LocalBuildInfo' if it exists, or make a fake package key based -- on the package ID. localCompatPackageKey :: LocalBuildInfo -> String localCompatPackageKey lbi =-    case componentNameCLBIs lbi (CLibName LMainLibName) of-        [LibComponentLocalBuildInfo { componentCompatPackageKey = pk }]-          -> pk-        _ -> prettyShow (localPackage lbi)+  case componentNameCLBIs lbi (CLibName LMainLibName) of+    [LibComponentLocalBuildInfo{componentCompatPackageKey = pk}] ->+      pk+    _ -> prettyShow (localPackage lbi)  -- | Convenience function to generate a default 'TargetInfo' from a -- 'ComponentLocalBuildInfo'.  The idea is to call this once, and then -- use 'TargetInfo' everywhere else.  Private to this module. mkTargetInfo :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> TargetInfo mkTargetInfo pkg_descr _lbi clbi =-    TargetInfo {-        targetCLBI = clbi,-        -- NB: @pkg_descr@, not @localPkgDescr lbi@!-        targetComponent = getComponent pkg_descr-                                       (componentLocalName clbi)-     }+  TargetInfo+    { targetCLBI = clbi+    , -- NB: @pkg_descr@, not @localPkgDescr lbi@!+      targetComponent =+        getComponent+          pkg_descr+          (componentLocalName clbi)+    }  -- | Return all 'TargetInfo's associated with 'ComponentName'. -- In the presence of Backpack there may be more than one! -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. componentNameTargets' :: PackageDescription -> LocalBuildInfo -> ComponentName -> [TargetInfo]-componentNameTargets' pkg_descr lbi cname =-    case Map.lookup cname (componentNameMap lbi) of-        Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis-        Nothing -> []+componentNameTargets' pkg_descr lbi@(LocalBuildInfo{componentNameMap = comps}) cname =+  case Map.lookup cname comps of+    Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis+    Nothing -> []  unitIdTarget' :: PackageDescription -> LocalBuildInfo -> UnitId -> Maybe TargetInfo-unitIdTarget' pkg_descr lbi uid =-    case Graph.lookup uid (componentGraph lbi) of-        Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi)-        Nothing -> Nothing+unitIdTarget' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) uid =+  case Graph.lookup uid compsGraph of+    Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi)+    Nothing -> Nothing  -- | Return all 'ComponentLocalBuildInfo's associated with 'ComponentName'. -- In the presence of Backpack there may be more than one! componentNameCLBIs :: LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo]-componentNameCLBIs lbi cname =-    case Map.lookup cname (componentNameMap lbi) of-        Just clbis -> clbis-        Nothing -> []+componentNameCLBIs (LocalBuildInfo{componentNameMap = comps}) cname =+  case Map.lookup cname comps of+    Just clbis -> clbis+    Nothing -> []  -- TODO: Maybe cache topsort (Graph can do this) @@ -246,24 +400,24 @@ -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. allTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [TargetInfo]-allTargetsInBuildOrder' pkg_descr lbi-    = map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (componentGraph lbi))+allTargetsInBuildOrder' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) =+  map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort compsGraph)  -- | Execute @f@ for every 'TargetInfo' in the package, respecting the -- build dependency order.  (TODO: We should use Shake!) -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. withAllTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> (TargetInfo -> IO ()) -> IO ()-withAllTargetsInBuildOrder' pkg_descr lbi f-    = sequence_ [ f target | target <- allTargetsInBuildOrder' pkg_descr lbi ]+withAllTargetsInBuildOrder' pkg_descr lbi f =+  sequence_ [f target | target <- allTargetsInBuildOrder' pkg_descr lbi]  -- | Return the list of all targets needed to build the @uids@, in -- the order they need to be built. -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. neededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo]-neededTargetsInBuildOrder' pkg_descr lbi uids =-  case Graph.closure (componentGraph lbi) uids of+neededTargetsInBuildOrder' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) uids =+  case Graph.closure compsGraph uids of     Nothing -> error $ "localBuildPlan: missing uids " ++ intercalate ", " (map prettyShow uids)     Just clos -> map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (Graph.fromDistinctList clos)) @@ -272,33 +426,77 @@ -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. withNeededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO ()-withNeededTargetsInBuildOrder' pkg_descr lbi uids f-    = sequence_ [ f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids ]+withNeededTargetsInBuildOrder' pkg_descr lbi uids f =+  sequence_ [f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids]  -- | Is coverage enabled for test suites? In practice, this requires library -- and executable profiling to be enabled. testCoverage :: LocalBuildInfo -> Bool-testCoverage lbi = exeCoverage lbi && libCoverage lbi+testCoverage (LocalBuildInfo{exeCoverage = exes, libCoverage = libs}) =+  exes && libs +-- | Returns a list of ways, in the order which they should be built, and the+-- way we build executable and foreign library components.+--+-- Ideally all this info should be fixed at configure time and not dependent on+-- additional info but `LocalBuildInfo` is per package (not per component) so it's+-- currently not possible to configure components to be built in certain ways.+buildWays :: LocalBuildInfo -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)+buildWays lbi =+  let+    -- enable-library-profiling (enable (static profiling way)) .p_o+    -- enable-shared (enabled dynamic way)  .dyn_o+    -- enable-profiling-shared (enable dynamic profilng way) .p_dyn_o+    -- enable-library-vanilla (enable vanilla way) .o+    --+    -- enable-executable-dynamic => build dynamic executables+    -- => --enable-profiling + --enable-executable-dynamic => build dynamic profiled executables+    -- => --enable-profiling => build vanilla profiled executables++    wantedLibWays is_indef =+      [ProfDynWay | withProfLibShared lbi && not is_indef]+        <> [ProfWay | withProfLib lbi]+        -- I don't see why we shouldn't build with dynamic-- indefinite components.+        <> [DynWay | withSharedLib lbi && not is_indef]+        -- MP: Ideally we should have `BuildOptions` on a per component basis, in+        -- which case this `is_indef` check could be moved to configure time.+        <> [StaticWay | withVanillaLib lbi || withStaticLib lbi]++    wantedFLibWay is_dyn_flib =+      case (is_dyn_flib, withProfExe lbi) of+        (True, True) -> ProfDynWay+        (False, True) -> ProfWay+        (True, False) -> DynWay+        (False, False) -> StaticWay++    wantedExeWay =+      case (withDynExe lbi, withProfExe lbi) of+        (True, True) -> ProfDynWay+        (True, False) -> DynWay+        (False, True) -> ProfWay+        (False, False) -> StaticWay+   in+    (wantedLibWays, wantedFLibWay, wantedExeWay)+ ------------------------------------------------------------------------------- -- Stub functions to prevent someone from accidentally defining them -{-# WARNING componentNameTargets, unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it.  See the documentation for 'HookedBuildInfo' for an explanation of the issue.  If you have a 'PakcageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-}-+{-# WARNING componentNameTargets, unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it.  See the documentation for 'HookedBuildInfo' for an explanation of the issue.  If you have a 'PackageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-} componentNameTargets :: LocalBuildInfo -> ComponentName -> [TargetInfo]-componentNameTargets lbi = componentNameTargets' (localPkgDescr lbi) lbi-+componentNameTargets lbi@(LocalBuildInfo{localPkgDescr = pkg}) =+  componentNameTargets' pkg lbi unitIdTarget :: LocalBuildInfo -> UnitId -> Maybe TargetInfo-unitIdTarget lbi = unitIdTarget' (localPkgDescr lbi) lbi-+unitIdTarget lbi@(LocalBuildInfo{localPkgDescr = pkg}) =+  unitIdTarget' pkg lbi allTargetsInBuildOrder :: LocalBuildInfo -> [TargetInfo]-allTargetsInBuildOrder lbi = allTargetsInBuildOrder' (localPkgDescr lbi) lbi-+allTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) =+  allTargetsInBuildOrder' pkg lbi withAllTargetsInBuildOrder :: LocalBuildInfo -> (TargetInfo -> IO ()) -> IO ()-withAllTargetsInBuildOrder lbi = withAllTargetsInBuildOrder' (localPkgDescr lbi) lbi-+withAllTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) =+  withAllTargetsInBuildOrder' pkg lbi neededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> [TargetInfo]-neededTargetsInBuildOrder lbi = neededTargetsInBuildOrder' (localPkgDescr lbi) lbi-+neededTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) =+  neededTargetsInBuildOrder' pkg lbi withNeededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO ()-withNeededTargetsInBuildOrder lbi = withNeededTargetsInBuildOrder' (localPkgDescr lbi) lbi+withNeededTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) =+  withNeededTargetsInBuildOrder' pkg lbi
− src/Distribution/Types/Mixin.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}--module Distribution.Types.Mixin (-    Mixin(..),-    mkMixin,-    normaliseMixin,-) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.CabalSpecVersion-import Distribution.Parsec-import Distribution.Pretty-import Distribution.Types.IncludeRenaming-import Distribution.Types.LibraryName-import Distribution.Types.PackageName-import Distribution.Types.UnqualComponentName--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as PP---- |------ /Invariant:/ if 'mixinLibraryName' is 'LSubLibName', it's not--- the same as 'mixinPackageName'. In other words,--- the same invariant as 'Dependency' has.----data Mixin = Mixin { mixinPackageName :: PackageName-                   , mixinLibraryName :: LibraryName-                   , mixinIncludeRenaming :: IncludeRenaming }-    deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)--instance Binary Mixin-instance Structured Mixin--instance NFData Mixin where rnf = genericRnf--instance Pretty Mixin where-    pretty (Mixin pn LMainLibName incl)     = pretty pn <+> pretty incl-    pretty (Mixin pn (LSubLibName ln) incl) = pretty pn <<>> PP.colon <<>> pretty ln <+> pretty incl---- |------ >>>  simpleParsec "mylib" :: Maybe Mixin--- Just (Mixin {mixinPackageName = PackageName "mylib", mixinLibraryName = LMainLibName, mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}})------ >>>  simpleParsec "thatlib:sublib" :: Maybe Mixin--- Just (Mixin {mixinPackageName = PackageName "thatlib", mixinLibraryName = LSubLibName (UnqualComponentName "sublib"), mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}})------ >>>  simpleParsec "thatlib:thatlib" :: Maybe Mixin--- Just (Mixin {mixinPackageName = PackageName "thatlib", mixinLibraryName = LMainLibName, mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}})------ Sublibrary syntax is accepted since @cabal-version: 3.4@.------ >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV3_0, CabalSpecV3_4] :: [Maybe Mixin]--- [Nothing,Just (Mixin {mixinPackageName = PackageName "mylib", mixinLibraryName = LSubLibName (UnqualComponentName "sub"), mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}})]----instance Parsec Mixin where-    parsec = do-        pn <- parsec-        ln <- P.option LMainLibName $ do-            _ <- P.char ':'-            versionGuardMultilibs-            parsecWarning PWTExperimental "colon specifier is experimental feature (issue #5660)"-            LSubLibName <$> parsec-        P.spaces-        incl <- parsec-        return (mkMixin pn ln incl)-      where--versionGuardMultilibs :: CabalParsing m => m ()-versionGuardMultilibs = do-  csv <- askCabalSpecVersion-  when (csv < CabalSpecV3_4) $ fail $ unwords-    [ "Sublibrary mixin syntax used."-    , "To use this syntax the package needs to specify at least 'cabal-version: 3.4'."-    ]---- | Smart constructor of 'Mixin', enforces invariant.--- --- @since 3.4.0.0-mkMixin :: PackageName -> LibraryName -> IncludeRenaming -> Mixin-mkMixin pn (LSubLibName uqn) incl-    | packageNameToUnqualComponentName pn == uqn-    = Mixin pn LMainLibName incl-mkMixin pn ln incl-    = Mixin pn ln incl---- | Restore invariant-normaliseMixin :: Mixin -> Mixin-normaliseMixin (Mixin pn ln incl) = mkMixin pn ln incl
− src/Distribution/Types/Module.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Distribution.Types.Module-  ( Module(..)-  ) where--import Prelude ()-import Distribution.Compat.Prelude--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp-import Distribution.Pretty-import Distribution.Parsec-import Distribution.Types.UnitId-import Distribution.ModuleName---- | A module identity uniquely identifies a Haskell module by--- qualifying a 'ModuleName' with the 'UnitId' which defined--- it.  This type distinguishes between two packages--- which provide a module with the same name, or a module--- from the same package compiled with different dependencies.--- There are a few cases where Cabal needs to know about--- module identities, e.g., when writing out reexported modules in--- the 'InstalledPackageInfo'.-data Module =-      Module DefUnitId ModuleName-    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)--instance Binary Module-instance Structured Module--instance Pretty Module where-    pretty (Module uid mod_name) =-        pretty uid <<>> Disp.text ":" <<>> pretty mod_name--instance Parsec Module where-    parsec = do-        uid <- parsec-        _ <- P.char ':'-        mod_name <- parsec-        return (Module uid mod_name)--instance NFData Module where-    rnf (Module uid mod_name) = rnf uid `seq` rnf mod_name
− src/Distribution/Types/ModuleReexport.hs 
@@ -1,50 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}--module Distribution.Types.ModuleReexport (-    ModuleReexport(..)-) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.ModuleName-import Distribution.Parsec-import Distribution.Pretty-import Distribution.Types.PackageName--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp---- -------------------------------------------------------------------------------- Module re-exports--data ModuleReexport = ModuleReexport {-       moduleReexportOriginalPackage :: Maybe PackageName,-       moduleReexportOriginalName    :: ModuleName,-       moduleReexportName            :: ModuleName-    }-    deriving (Eq, Generic, Read, Show, Typeable, Data)--instance Binary ModuleReexport-instance Structured ModuleReexport-instance NFData ModuleReexport where rnf = genericRnf--instance Pretty ModuleReexport where-    pretty (ModuleReexport mpkgname origname newname) =-          maybe Disp.empty (\pkgname -> pretty pkgname <<>> Disp.char ':') mpkgname-       <<>> pretty origname-      <+> if newname == origname-            then Disp.empty-            else Disp.text "as" <+> pretty newname--instance Parsec ModuleReexport where-    parsec = do-        mpkgname <- P.optional (P.try $ parsec <* P.char ':')-        origname <- parsec-        newname  <- P.option origname $ P.try $ do-            P.spaces-            _ <- P.string "as"-            P.spaces-            parsec-        return (ModuleReexport mpkgname origname newname)
− src/Distribution/Types/ModuleRenaming.hs 
@@ -1,134 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE RankNTypes         #-}--module Distribution.Types.ModuleRenaming (-    ModuleRenaming(..),-    interpModuleRenaming,-    defaultRenaming,-    isDefaultRenaming,-) where--import Distribution.CabalSpecVersion-import Distribution.Compat.Prelude hiding (empty)-import Prelude ()--import Distribution.ModuleName-import Distribution.Parsec-import Distribution.Pretty--import qualified Data.Map                   as Map-import qualified Data.Set                   as Set-import qualified Distribution.Compat.CharParsing as P-import           Text.PrettyPrint           (hsep, parens, punctuate, text, comma)---- | Renaming applied to the modules provided by a package.--- The boolean indicates whether or not to also include all of the--- original names of modules.  Thus, @ModuleRenaming False []@ is--- "don't expose any modules, and @ModuleRenaming True [("Data.Bool", "Bool")]@--- is, "expose all modules, but also expose @Data.Bool@ as @Bool@".--- If a renaming is omitted you get the 'DefaultRenaming'.------ (NB: This is a list not a map so that we can preserve order.)----data ModuleRenaming-        -- | A module renaming/thinning; e.g., @(A as B, C as C)@-        -- brings @B@ and @C@ into scope.-        = ModuleRenaming [(ModuleName, ModuleName)]-        -- | The default renaming, bringing all exported modules-        -- into scope.-        | DefaultRenaming-        -- | Hiding renaming, e.g., @hiding (A, B)@, bringing all-        -- exported modules into scope except the hidden ones.-        | HidingRenaming [ModuleName]-    deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)---- | Interpret a 'ModuleRenaming' as a partial map from 'ModuleName'--- to 'ModuleName'.  For efficiency, you should partially apply it--- with 'ModuleRenaming' and then reuse it.-interpModuleRenaming :: ModuleRenaming -> ModuleName -> Maybe ModuleName-interpModuleRenaming DefaultRenaming = Just-interpModuleRenaming (ModuleRenaming rns) =-    let m = Map.fromList rns-    in \k -> Map.lookup k m-interpModuleRenaming (HidingRenaming hs) =-    let s = Set.fromList hs-    in \k -> if k `Set.member` s then Nothing else Just k---- | The default renaming, if something is specified in @build-depends@--- only.-defaultRenaming :: ModuleRenaming-defaultRenaming = DefaultRenaming---- | Tests if its the default renaming; we can use a more compact syntax--- in 'Distribution.Types.IncludeRenaming.IncludeRenaming' in this case.-isDefaultRenaming :: ModuleRenaming -> Bool-isDefaultRenaming DefaultRenaming = True-isDefaultRenaming _ = False----instance Binary ModuleRenaming where-instance Structured ModuleRenaming where--instance NFData ModuleRenaming where rnf = genericRnf---- NB: parentheses are mandatory, because later we may extend this syntax--- to allow "hiding (A, B)" or other modifier words.-instance Pretty ModuleRenaming where-  pretty DefaultRenaming = mempty-  pretty (HidingRenaming hides)-        = text "hiding" <+> parens (hsep (punctuate comma (map pretty hides)))-  pretty (ModuleRenaming rns)-        = parens . hsep $ punctuate comma (map dispEntry rns)-    where dispEntry (orig, new)-            | orig == new = pretty orig-            | otherwise = pretty orig <+> text "as" <+> pretty new--instance Parsec ModuleRenaming where-    parsec = do-        csv <- askCabalSpecVersion-        if csv >= CabalSpecV3_0-        then moduleRenamingParsec parensLax    lexemeParsec-        else moduleRenamingParsec parensStrict parsec-      where-        -- For cabal spec versions < 3.0 white spaces were not skipped-        -- after the '(' and ')' tokens in the mixin field. This-        -- parser checks the cabal file version and does the correct-        -- skipping of spaces.-        parensLax    p = P.between (P.char '(' >> P.spaces)   (P.char ')' >> P.spaces)   p-        parensStrict p = P.between (P.char '(' >> warnSpaces) (P.char ')') p--        warnSpaces = P.optional $-            P.space *> fail "space after parenthesis, use cabal-version: 3.0 or higher"--moduleRenamingParsec-    :: CabalParsing m-    => (forall a. m a -> m a)  -- ^ between parens-    -> m ModuleName            -- ^ module name parser-    -> m ModuleRenaming-moduleRenamingParsec bp mn =-    -- NB: try not necessary as the first token is obvious-    P.choice [ parseRename, parseHiding, return DefaultRenaming ]-  where-    cma = P.char ',' >> P.spaces-    parseRename = do-        rns <- bp parseList-        P.spaces-        return (ModuleRenaming rns)-    parseHiding = do-        _ <- P.string "hiding"-        P.spaces -- space isn't strictly required as next is an open paren-        hides <- bp (P.sepBy mn cma)-        return (HidingRenaming hides)-    parseList =-        P.sepBy parseEntry cma-    parseEntry = do-        orig <- parsec-        P.spaces-        P.option (orig, orig) $ do-            _ <- P.string "as"-            P.skipSpaces1 -- require space after "as"-            new <- parsec-            P.spaces-            return (orig, new)
− src/Distribution/Types/MungedPackageId.hs 
@@ -1,83 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.Types.MungedPackageId-  ( MungedPackageId(..)-  , computeCompatPackageId-  ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty-import Distribution.Types.LibraryName-import Distribution.Types.MungedPackageName-import Distribution.Types.PackageId-import Distribution.Version                 (Version, nullVersion)--import qualified Text.PrettyPrint as Disp---- | A simple pair of a 'MungedPackageName' and 'Version'. 'MungedPackageName' is to--- 'MungedPackageId' as 'PackageName' is to 'PackageId'. See 'MungedPackageName' for more--- info.-data MungedPackageId-    = MungedPackageId {-        -- | The combined package and component name. see documentation for-        -- 'MungedPackageName'.-        mungedName    :: MungedPackageName,-        -- | The version of this package / component, eg 1.2-        mungedVersion :: Version-     }-     deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)--instance Binary MungedPackageId-instance Structured MungedPackageId---- |------ >>> prettyShow $ MungedPackageId (MungedPackageName "servant" LMainLibName) (mkVersion [1,2,3])--- "servant-1.2.3"------ >>> prettyShow $ MungedPackageId (MungedPackageName "servant" (LSubLibName "lackey")) (mkVersion [0,1,2])--- "z-servant-z-lackey-0.1.2"----instance Pretty MungedPackageId where-    pretty (MungedPackageId n v)-        | v == nullVersion = pretty n -- if no version, don't show version.-        | otherwise        = pretty n <<>> Disp.char '-' <<>> pretty v---- |------ >>> simpleParsec "foo-bar-0" :: Maybe MungedPackageId--- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") LMainLibName, mungedVersion = mkVersion [0]})------ >>> simpleParsec "foo-bar" :: Maybe MungedPackageId--- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") LMainLibName, mungedVersion = mkVersion []})------ >>> simpleParsec "z-foo-bar-z-baz-0" :: Maybe MungedPackageId--- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") (LSubLibName (UnqualComponentName "baz")), mungedVersion = mkVersion [0]})------ >>> simpleParsec "foo-bar-0-0" :: Maybe MungedPackageId--- Nothing------ >>> simpleParsec "foo-bar.0" :: Maybe MungedPackageId--- Nothing------ >>> simpleParsec "foo-bar.4-2" :: Maybe MungedPackageId--- Nothing----instance Parsec MungedPackageId where-    parsec = do-        PackageIdentifier pn v <- parsec-        return $ MungedPackageId (decodeCompatPackageName pn) v--instance NFData MungedPackageId where-    rnf (MungedPackageId name version) = rnf name `seq` rnf version--computeCompatPackageId :: PackageId -> LibraryName -> MungedPackageId-computeCompatPackageId (PackageIdentifier pn vr) ln =-    MungedPackageId (MungedPackageName pn ln) vr---- $setup--- >>> :seti -XOverloadedStrings--- >>> import Distribution.Types.Version
− src/Distribution/Types/MungedPackageName.hs 
@@ -1,157 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.Types.MungedPackageName-  ( MungedPackageName (..)-  , decodeCompatPackageName-  , encodeCompatPackageName-  ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty-import Distribution.Types.LibraryName-import Distribution.Types.PackageName-import Distribution.Types.UnqualComponentName--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp---- | A combination of a package and component name used in various legacy--- interfaces, chiefly bundled with a version as 'MungedPackageId'. It's generally--- better to use a 'UnitId' to opaquely refer to some compilation/packing unit,--- but that doesn't always work, e.g. where a "name" is needed, in which case--- this can be used as a fallback.------ Use 'mkMungedPackageName' and 'unMungedPackageName' to convert from/to a 'String'.------ In @3.0.0.0@ representation was changed from opaque (string) to semantic representation.------ @since 2.0.0.2----data MungedPackageName = MungedPackageName !PackageName !LibraryName-  deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)--instance Binary MungedPackageName-instance Structured MungedPackageName-instance NFData MungedPackageName where rnf = genericRnf---- | Computes the package name for a library.  If this is the public--- library, it will just be the original package name; otherwise,--- it will be a munged package name recording the original package--- name as well as the name of the internal library.------ A lot of tooling in the Haskell ecosystem assumes that if something--- is installed to the package database with the package name 'foo',--- then it actually is an entry for the (only public) library in package--- 'foo'.  With internal packages, this is not necessarily true:--- a public library as well as arbitrarily many internal libraries may--- come from the same package.  To prevent tools from getting confused--- in this case, the package name of these internal libraries is munged--- so that they do not conflict the public library proper.  A particular--- case where this matters is ghc-pkg: if we don't munge the package--- name, the inplace registration will OVERRIDE a different internal--- library.------ We munge into a reserved namespace, "z-", and encode both the--- component name and the package name of an internal library using the--- following format:------      compat-pkg-name ::= "z-" package-name "-z-" library-name------ where package-name and library-name have "-" ( "z" + ) "-"--- segments encoded by adding an extra "z".------ When we have the public library, the compat-pkg-name is just the--- package-name, no surprises there!------ >>> prettyShow $ MungedPackageName "servant" LMainLibName--- "servant"------ >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey")--- "z-servant-z-lackey"----instance Pretty MungedPackageName where-    -- First handle the cases where we can just use the original 'PackageName'.-    -- This is for the PRIMARY library, and it is non-Backpack, or the-    -- indefinite package for us.-    pretty = Disp.text . encodeCompatPackageName'---- |------ >>> simpleParsec "servant" :: Maybe MungedPackageName--- Just (MungedPackageName (PackageName "servant") LMainLibName)------ >>> simpleParsec "z-servant-z-lackey" :: Maybe MungedPackageName--- Just (MungedPackageName (PackageName "servant") (LSubLibName (UnqualComponentName "lackey")))------ >>> simpleParsec "z-servant-zz" :: Maybe MungedPackageName--- Just (MungedPackageName (PackageName "z-servant-zz") LMainLibName)----instance Parsec MungedPackageName where-    parsec = decodeCompatPackageName' <$> parsecUnqualComponentName------------------------------------------------------------------------------------ ZDashCode conversions------------------------------------------------------------------------------------ | Intended for internal use only------ >>> decodeCompatPackageName "z-servant-z-lackey"--- MungedPackageName (PackageName "servant") (LSubLibName (UnqualComponentName "lackey"))----decodeCompatPackageName :: PackageName -> MungedPackageName-decodeCompatPackageName = decodeCompatPackageName' . unPackageName---- | Intended for internal use only------ >>> encodeCompatPackageName $ MungedPackageName "servant" (LSubLibName "lackey")--- PackageName "z-servant-z-lackey"------ This is used in @cabal-install@ in the Solver.--- May become obsolete as solver moves to per-component solving.----encodeCompatPackageName :: MungedPackageName -> PackageName-encodeCompatPackageName = mkPackageName . encodeCompatPackageName'--decodeCompatPackageName' :: String -> MungedPackageName-decodeCompatPackageName' m =-    case m of-        'z':'-':rest | Right [pn, cn] <- explicitEitherParsec parseZDashCode rest-            -> MungedPackageName (mkPackageName pn) (LSubLibName (mkUnqualComponentName cn))-        s   -> MungedPackageName (mkPackageName s) LMainLibName--encodeCompatPackageName' :: MungedPackageName -> String-encodeCompatPackageName' (MungedPackageName pn LMainLibName)      = unPackageName pn-encodeCompatPackageName' (MungedPackageName pn (LSubLibName uqn)) =-     "z-" ++ zdashcode (unPackageName pn) ++-    "-z-" ++ zdashcode (unUnqualComponentName uqn)--zdashcode :: String -> String-zdashcode s = go s (Nothing :: Maybe Int) []-    where go [] _ r = reverse r-          go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r)-          go ('-':z) _        r = go z (Just 0) ('-':r)-          go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r)-          go (c:z)   _        r = go z Nothing (c:r)--parseZDashCode :: CabalParsing m => m [String]-parseZDashCode = do-    ns <- toList <$> P.sepByNonEmpty (some (P.satisfy (/= '-'))) (P.char '-')-    return (go ns)-  where-    go ns = case break (=="z") ns of-                (_, []) -> [paste ns]-                (as, "z":bs) -> paste as : go bs-                _ -> error "parseZDashCode: go"-    unZ :: String -> String-    unZ "" = error "parseZDashCode: unZ"-    unZ r@('z':zs) | all (=='z') zs = zs-                   | otherwise      = r-    unZ r = r-    paste :: [String] -> String-    paste = intercalate "-" . map unZ---- $setup--- >>> :seti -XOverloadedStrings
− src/Distribution/Types/PackageDescription.hs 
@@ -1,457 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Types.PackageDescription--- Copyright   :  Isaac Jones 2003-2005--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This defines the data structure for the @.cabal@ file format. There are--- several parts to this structure. It has top level info and then 'Library',--- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have--- associated 'BuildInfo' data that's used to build the library, exe, test, or--- benchmark.  To further complicate things there is both a 'PackageDescription'--- and a 'GenericPackageDescription'. This distinction relates to cabal--- configurations. When we initially read a @.cabal@ file we get a--- 'GenericPackageDescription' which has all the conditional sections.--- Before actually building a package we have to decide--- on each conditional. Once we've done that we get a 'PackageDescription'.--- It was done this way initially to avoid breaking too much stuff when the--- feature was introduced. It could probably do with being rationalised at some--- point to make it simpler.--module Distribution.Types.PackageDescription (-    PackageDescription(..),-    license,-    license',-    buildType,-    emptyPackageDescription,-    hasPublicLib,-    hasLibs,-    allLibraries,-    withLib,-    hasExes,-    withExe,-    hasTests,-    withTest,-    hasBenchmarks,-    withBenchmark,-    hasForeignLibs,-    withForeignLib,-    allBuildInfo,-    enabledBuildInfos,-    allBuildDepends,-    enabledBuildDepends,-    updatePackageDescription,-    pkgComponents,-    pkgBuildableComponents,-    enabledComponents,-    lookupComponent,-    getComponent,-  ) where--import Prelude ()-import Distribution.Compat.Prelude--import Control.Monad ((<=<))---- lens-import qualified Distribution.Types.BuildInfo.Lens  as L-import Distribution.Types.Library-import Distribution.Types.TestSuite-import Distribution.Types.Executable-import Distribution.Types.Benchmark-import Distribution.Types.ForeignLib--import Distribution.Types.Component-import Distribution.Types.ComponentRequestedSpec-import Distribution.Types.Dependency-import Distribution.Types.PackageId-import Distribution.Types.ComponentName-import Distribution.Types.PackageName-import Distribution.Types.UnqualComponentName-import Distribution.Types.SetupBuildInfo-import Distribution.Types.BuildInfo-import Distribution.Types.BuildType-import Distribution.Types.SourceRepo-import Distribution.Types.HookedBuildInfo--import Distribution.CabalSpecVersion-import Distribution.Compiler-import Distribution.License-import Distribution.Package-import Distribution.Version-import Distribution.Utils.Path-import Distribution.Utils.ShortText--import qualified Distribution.SPDX as SPDX---- -------------------------------------------------------------------------------- The PackageDescription type---- | This data type is the internal representation of the file @pkg.cabal@.--- It contains two kinds of information about the package: information--- which is needed for all packages, such as the package name and version, and--- information which is needed for the simple build system only, such as--- the compiler options and library name.----data PackageDescription-    =  PackageDescription {-        -- the following are required by all packages:--        -- | The version of the Cabal spec that this package description uses.-        specVersion    :: CabalSpecVersion,-        package        :: PackageIdentifier,-        licenseRaw     :: Either SPDX.License License,-        licenseFiles   :: [SymbolicPath PackageDir LicenseFile],-        copyright      :: !ShortText,-        maintainer     :: !ShortText,-        author         :: !ShortText,-        stability      :: !ShortText,-        testedWith     :: [(CompilerFlavor,VersionRange)],-        homepage       :: !ShortText,-        pkgUrl         :: !ShortText,-        bugReports     :: !ShortText,-        sourceRepos    :: [SourceRepo],-        synopsis       :: !ShortText, -- ^A one-line summary of this package-        description    :: !ShortText, -- ^A more verbose description of this package-        category       :: !ShortText,-        customFieldsPD :: [(String,String)], -- ^Custom fields starting-                                             -- with x-, stored in a-                                             -- simple assoc-list.--        -- | The original @build-type@ value as parsed from the-        -- @.cabal@ file without defaulting. See also 'buildType'.-        ---        -- @since 2.2-        buildTypeRaw   :: Maybe BuildType,-        setupBuildInfo :: Maybe SetupBuildInfo,-        -- components-        library        :: Maybe Library,-        subLibraries   :: [Library],-        executables    :: [Executable],-        foreignLibs    :: [ForeignLib],-        testSuites     :: [TestSuite],-        benchmarks     :: [Benchmark],-        -- files-        dataFiles      :: [FilePath],-        dataDir        :: FilePath,-        extraSrcFiles  :: [FilePath],-        extraTmpFiles  :: [FilePath],-        extraDocFiles  :: [FilePath]-    }-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary PackageDescription-instance Structured PackageDescription--instance NFData PackageDescription where rnf = genericRnf--instance Package PackageDescription where-  packageId = package---- | The SPDX 'LicenseExpression' of the package.------ @since 2.2.0.0-license :: PackageDescription -> SPDX.License-license = license' . licenseRaw---- | See 'license'.------ @since 2.2.0.0-license' :: Either SPDX.License License -> SPDX.License-license' = either id licenseToSPDX---- | The effective @build-type@ after applying defaulting rules.------ The original @build-type@ value parsed is stored in the--- 'buildTypeRaw' field.  However, the @build-type@ field is optional--- and can therefore be empty in which case we need to compute the--- /effective/ @build-type@. This function implements the following--- defaulting rules:------  * For @cabal-version:2.0@ and below, default to the @Custom@---    build-type unconditionally.------  * Otherwise, if a @custom-setup@ stanza is defined, default to---    the @Custom@ build-type; else default to @Simple@ build-type.------ @since 2.2-buildType :: PackageDescription -> BuildType-buildType pkg-  | specVersion pkg >= CabalSpecV2_2-    = fromMaybe newDefault (buildTypeRaw pkg)-  | otherwise -- cabal-version < 2.1-    = fromMaybe Custom (buildTypeRaw pkg)-  where-    newDefault | isNothing (setupBuildInfo pkg) = Simple-               | otherwise                      = Custom--emptyPackageDescription :: PackageDescription-emptyPackageDescription-    =  PackageDescription {-                      package      = PackageIdentifier (mkPackageName "")-                                                       nullVersion,-                      licenseRaw   = Right UnspecifiedLicense, -- TODO:-                      licenseFiles = [],-                      specVersion  = CabalSpecV1_0,-                      buildTypeRaw = Nothing,-                      copyright    = mempty,-                      maintainer   = mempty,-                      author       = mempty,-                      stability    = mempty,-                      testedWith   = [],-                      homepage     = mempty,-                      pkgUrl       = mempty,-                      bugReports   = mempty,-                      sourceRepos  = [],-                      synopsis     = mempty,-                      description  = mempty,-                      category     = mempty,-                      customFieldsPD = [],-                      setupBuildInfo = Nothing,-                      library      = Nothing,-                      subLibraries = [],-                      foreignLibs  = [],-                      executables  = [],-                      testSuites   = [],-                      benchmarks   = [],-                      dataFiles    = [],-                      dataDir      = ".",-                      extraSrcFiles = [],-                      extraTmpFiles = [],-                      extraDocFiles = []-                     }---- ------------------------------------------------------------------------------ The Library type---- | Does this package have a buildable PUBLIC library?-hasPublicLib :: PackageDescription -> Bool-hasPublicLib p =-    case library p of-        Just lib -> buildable (libBuildInfo lib)-        Nothing  -> False---- | Does this package have any libraries?-hasLibs :: PackageDescription -> Bool-hasLibs p = any (buildable . libBuildInfo) (allLibraries p)--allLibraries :: PackageDescription -> [Library]-allLibraries p = maybeToList (library p) ++ subLibraries p---- | If the package description has a buildable library section,--- call the given function with the library build info as argument.--- You probably want 'withLibLBI' if you have a 'LocalBuildInfo',--- see the note in--- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components"--- for more information.-withLib :: PackageDescription -> (Library -> IO ()) -> IO ()-withLib pkg_descr f =-   sequence_ [f lib | lib <- allLibraries pkg_descr, buildable (libBuildInfo lib)]---- ------------------------------------------------------------------------------ The Executable type---- |does this package have any executables?-hasExes :: PackageDescription -> Bool-hasExes p = any (buildable . buildInfo) (executables p)---- | Perform the action on each buildable 'Executable' in the package--- description.  You probably want 'withExeLBI' if you have a--- 'LocalBuildInfo', see the note in--- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components"--- for more information.-withExe :: PackageDescription -> (Executable -> IO ()) -> IO ()-withExe pkg_descr f =-  sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)]---- ------------------------------------------------------------------------------ The TestSuite type---- | Does this package have any test suites?-hasTests :: PackageDescription -> Bool-hasTests = any (buildable . testBuildInfo) . testSuites---- | Perform an action on each buildable 'TestSuite' in a package.--- You probably want 'withTestLBI' if you have a 'LocalBuildInfo', see the note in--- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components"--- for more information.--withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO ()-withTest pkg_descr f =-    sequence_ [ f test | test <- testSuites pkg_descr, buildable (testBuildInfo test) ]---- ------------------------------------------------------------------------------ The Benchmark type---- | Does this package have any benchmarks?-hasBenchmarks :: PackageDescription -> Bool-hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks---- | Perform an action on each buildable 'Benchmark' in a package.--- You probably want 'withBenchLBI' if you have a 'LocalBuildInfo', see the note in--- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components"--- for more information.--withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO ()-withBenchmark pkg_descr f =-    sequence_ [f bench | bench <- benchmarks pkg_descr, buildable (benchmarkBuildInfo bench)]---- ------------------------------------------------------------------------------ The ForeignLib type---- | Does this package have any foreign libraries?-hasForeignLibs :: PackageDescription -> Bool-hasForeignLibs p = any (buildable . foreignLibBuildInfo) (foreignLibs p)---- | Perform the action on each buildable 'ForeignLib' in the package--- description.-withForeignLib :: PackageDescription -> (ForeignLib -> IO ()) -> IO ()-withForeignLib pkg_descr f =-  sequence_ [ f flib-            | flib <- foreignLibs pkg_descr-            , buildable (foreignLibBuildInfo flib)-            ]---- ------------------------------------------------------------------------------ The BuildInfo type---- | All 'BuildInfo' in the 'PackageDescription':--- libraries, executables, test-suites and benchmarks.------ Useful for implementing package checks.-allBuildInfo :: PackageDescription -> [BuildInfo]-allBuildInfo pkg_descr = [ bi | lib <- allLibraries pkg_descr-                               , let bi = libBuildInfo lib ]-                       ++ [ bi | flib <- foreignLibs pkg_descr-                               , let bi = foreignLibBuildInfo flib ]-                       ++ [ bi | exe <- executables pkg_descr-                               , let bi = buildInfo exe ]-                       ++ [ bi | tst <- testSuites pkg_descr-                               , let bi = testBuildInfo tst ]-                       ++ [ bi | tst <- benchmarks pkg_descr-                               , let bi = benchmarkBuildInfo tst ]---- | Return all of the 'BuildInfo's of enabled components, i.e., all of--- the ones that would be built if you run @./Setup build@.-enabledBuildInfos :: PackageDescription -> ComponentRequestedSpec -> [BuildInfo]-enabledBuildInfos pkg enabled =-    [ componentBuildInfo comp-    | comp <- enabledComponents pkg enabled ]----- --------------------------------------------------------------- * Utils--- ---------------------------------------------------------------- | Get the combined build-depends entries of all components.-allBuildDepends :: PackageDescription -> [Dependency]-allBuildDepends = targetBuildDepends <=< allBuildInfo---- | Get the combined build-depends entries of all enabled components, per the--- given request spec.-enabledBuildDepends :: PackageDescription -> ComponentRequestedSpec -> [Dependency]-enabledBuildDepends spec pd = targetBuildDepends =<< enabledBuildInfos spec pd---updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription-updatePackageDescription (mb_lib_bi, exe_bi) p-    = p{ executables = updateExecutables exe_bi    (executables p)-       , library     = updateLibrary     mb_lib_bi (library     p) }-    where-      updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library-      updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib})-      updateLibrary Nothing   mb_lib     = mb_lib-      updateLibrary (Just _)  Nothing    = Nothing--      updateExecutables :: [(UnqualComponentName, BuildInfo)] -- ^[(exeName, new buildinfo)]-        -> [Executable]                                       -- ^list of executables to update-        -> [Executable]                                       -- ^list with exeNames updated-      updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi'--      updateExecutable :: (UnqualComponentName, BuildInfo) -- ^(exeName, new buildinfo)-                       -> [Executable]                     -- ^list of executables to update-                       -> [Executable]                     -- ^list with exeName updated-      updateExecutable _                 []         = []-      updateExecutable exe_bi'@(name,bi) (exe:exes)-        | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes-        | otherwise           = exe : updateExecutable exe_bi' exes---- -------------------------------------------------------------------------------- Source-representation of buildable components---- | All the components in the package.----pkgComponents :: PackageDescription -> [Component]-pkgComponents pkg =-    [ CLib  lib | lib <- allLibraries pkg ]- ++ [ CFLib flib | flib <- foreignLibs pkg ]- ++ [ CExe  exe | exe <- executables pkg ]- ++ [ CTest tst | tst <- testSuites  pkg ]- ++ [ CBench bm | bm  <- benchmarks  pkg ]---- | A list of all components in the package that are buildable,--- i.e., were not marked with @buildable: False@.  This does NOT--- indicate if we are actually going to build the component,--- see 'enabledComponents' instead.------ @since 2.0.0.2----pkgBuildableComponents :: PackageDescription -> [Component]-pkgBuildableComponents = filter componentBuildable . pkgComponents---- | A list of all components in the package that are enabled.------ @since 2.0.0.2----enabledComponents :: PackageDescription -> ComponentRequestedSpec -> [Component]-enabledComponents pkg enabled = filter (componentEnabled enabled) $ pkgBuildableComponents pkg--lookupComponent :: PackageDescription -> ComponentName -> Maybe Component-lookupComponent pkg (CLibName name) =-    fmap CLib $ find ((name ==) . libName) (allLibraries pkg)-lookupComponent pkg (CFLibName name) =-    fmap CFLib $ find ((name ==) . foreignLibName) (foreignLibs pkg)-lookupComponent pkg (CExeName name) =-    fmap CExe $ find ((name ==) . exeName) (executables pkg)-lookupComponent pkg (CTestName name) =-    fmap CTest $ find ((name ==) . testName) (testSuites pkg)-lookupComponent pkg (CBenchName name) =-    fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)--getComponent :: PackageDescription -> ComponentName -> Component-getComponent pkg cname =-    case lookupComponent pkg cname of-      Just cpnt -> cpnt-      Nothing   -> missingComponent-  where-    missingComponent =-      error $ "internal error: the package description contains no "-           ++ "component corresponding to " ++ show cname---- -------------------------------------------------------------------------------- Traversal Instances--instance L.HasBuildInfos PackageDescription where-  traverseBuildInfos f (PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19-                                   x1 x2 x3 x4 x5 x6-                                   a20 a21 a22 a23 a24) =-    PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19-        <$> (traverse . L.buildInfo) f x1 -- library-        <*> (traverse . L.buildInfo) f x2 -- sub libraries-        <*> (traverse . L.buildInfo) f x3 -- executables-        <*> (traverse . L.buildInfo) f x4 -- foreign libs-        <*> (traverse . L.buildInfo) f x5 -- test suites-        <*> (traverse . L.buildInfo) f x6 -- benchmarks-        <*> pure a20                      -- data files-        <*> pure a21                      -- data dir-        <*> pure a22                      -- extra src files-        <*> pure a23                      -- extra temp files-        <*> pure a24                      -- extra doc files
− src/Distribution/Types/PackageDescription/Lens.hs 
@@ -1,221 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes        #-}-module Distribution.Types.PackageDescription.Lens (-    PackageDescription,-    module Distribution.Types.PackageDescription.Lens,-    ) where--import Distribution.Compat.Lens-import Distribution.Compat.Prelude-import Prelude ()--import Distribution.CabalSpecVersion         (CabalSpecVersion)-import Distribution.Compiler                 (CompilerFlavor)-import Distribution.License                  (License)-import Distribution.ModuleName               (ModuleName)-import Distribution.Types.Benchmark          (Benchmark, benchmarkModules)-import Distribution.Types.Benchmark.Lens     (benchmarkBuildInfo, benchmarkName)-import Distribution.Types.BuildInfo          (BuildInfo)-import Distribution.Types.BuildType          (BuildType)-import Distribution.Types.ComponentName      (ComponentName (..))-import Distribution.Types.Executable         (Executable, exeModules)-import Distribution.Types.Executable.Lens    (exeBuildInfo, exeName)-import Distribution.Types.ForeignLib         (ForeignLib, foreignLibModules)-import Distribution.Types.ForeignLib.Lens    (foreignLibBuildInfo, foreignLibName)-import Distribution.Types.Library            (Library, explicitLibModules)-import Distribution.Types.Library.Lens       (libBuildInfo, libName)-import Distribution.Types.PackageDescription (PackageDescription)-import Distribution.Types.PackageId          (PackageIdentifier)-import Distribution.Types.SetupBuildInfo     (SetupBuildInfo)-import Distribution.Types.SourceRepo         (SourceRepo)-import Distribution.Types.TestSuite          (TestSuite, testModules)-import Distribution.Types.TestSuite.Lens     (testBuildInfo, testName)-import Distribution.Utils.Path               (LicenseFile, PackageDir, SymbolicPath)-import Distribution.Utils.ShortText          (ShortText)-import Distribution.Version                  (VersionRange)--import qualified Distribution.SPDX                     as SPDX-import qualified Distribution.Types.PackageDescription as T--package :: Lens' PackageDescription PackageIdentifier-package f s = fmap (\x -> s { T.package = x }) (f (T.package s))-{-# INLINE package #-}--licenseRaw :: Lens' PackageDescription (Either SPDX.License License)-licenseRaw f s = fmap (\x -> s { T.licenseRaw = x }) (f (T.licenseRaw s))-{-# INLINE licenseRaw #-}--licenseFiles :: Lens' PackageDescription [SymbolicPath PackageDir LicenseFile]-licenseFiles f s = fmap (\x -> s { T.licenseFiles = x }) (f (T.licenseFiles s))-{-# INLINE licenseFiles #-}--copyright :: Lens' PackageDescription ShortText-copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s))-{-# INLINE copyright #-}--maintainer :: Lens' PackageDescription ShortText-maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s))-{-# INLINE maintainer #-}--author :: Lens' PackageDescription ShortText-author f s = fmap (\x -> s { T.author = x }) (f (T.author s))-{-# INLINE author #-}--stability :: Lens' PackageDescription ShortText-stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s))-{-# INLINE stability #-}--testedWith :: Lens' PackageDescription [(CompilerFlavor,VersionRange)]-testedWith f s = fmap (\x -> s { T.testedWith = x }) (f (T.testedWith s))-{-# INLINE testedWith #-}--homepage :: Lens' PackageDescription ShortText-homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s))-{-# INLINE homepage #-}--pkgUrl :: Lens' PackageDescription ShortText-pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s))-{-# INLINE pkgUrl #-}--bugReports :: Lens' PackageDescription ShortText-bugReports f s = fmap (\x -> s { T.bugReports = x }) (f (T.bugReports s))-{-# INLINE bugReports #-}--sourceRepos :: Lens' PackageDescription [SourceRepo]-sourceRepos f s = fmap (\x -> s { T.sourceRepos = x }) (f (T.sourceRepos s))-{-# INLINE sourceRepos #-}--synopsis :: Lens' PackageDescription ShortText-synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s))-{-# INLINE synopsis #-}--description :: Lens' PackageDescription ShortText-description f s = fmap (\x -> s { T.description = x }) (f (T.description s))-{-# INLINE description #-}--category :: Lens' PackageDescription ShortText-category f s = fmap (\x -> s { T.category = x }) (f (T.category s))-{-# INLINE category #-}--customFieldsPD :: Lens' PackageDescription [(String,String)]-customFieldsPD f s = fmap (\x -> s { T.customFieldsPD = x }) (f (T.customFieldsPD s))-{-# INLINE customFieldsPD #-}--specVersion :: Lens' PackageDescription CabalSpecVersion-specVersion f s = fmap (\x -> s { T.specVersion = x }) (f (T.specVersion s))-{-# INLINE specVersion #-}--buildTypeRaw :: Lens' PackageDescription (Maybe BuildType)-buildTypeRaw f s = fmap (\x -> s { T.buildTypeRaw = x }) (f (T.buildTypeRaw s))-{-# INLINE buildTypeRaw #-}--setupBuildInfo :: Lens' PackageDescription (Maybe SetupBuildInfo)-setupBuildInfo f s = fmap (\x -> s { T.setupBuildInfo = x }) (f (T.setupBuildInfo s))-{-# INLINE setupBuildInfo #-}--library :: Lens' PackageDescription (Maybe Library)-library f s = fmap (\x -> s { T.library = x }) (f (T.library s))-{-# INLINE library #-}--subLibraries :: Lens' PackageDescription [Library]-subLibraries f s = fmap (\x -> s { T.subLibraries = x }) (f (T.subLibraries s))-{-# INLINE subLibraries #-}--executables :: Lens' PackageDescription [Executable]-executables f s = fmap (\x -> s { T.executables = x }) (f (T.executables s))-{-# INLINE executables #-}--foreignLibs :: Lens' PackageDescription [ForeignLib]-foreignLibs f s = fmap (\x -> s { T.foreignLibs = x }) (f (T.foreignLibs s))-{-# INLINE foreignLibs #-}--testSuites :: Lens' PackageDescription [TestSuite]-testSuites f s = fmap (\x -> s { T.testSuites = x }) (f (T.testSuites s))-{-# INLINE testSuites #-}--benchmarks :: Lens' PackageDescription [Benchmark]-benchmarks f s = fmap (\x -> s { T.benchmarks = x }) (f (T.benchmarks s))-{-# INLINE benchmarks #-}--dataFiles :: Lens' PackageDescription [FilePath]-dataFiles f s = fmap (\x -> s { T.dataFiles = x }) (f (T.dataFiles s))-{-# INLINE dataFiles #-}--dataDir :: Lens' PackageDescription FilePath-dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s))-{-# INLINE dataDir #-}--extraSrcFiles :: Lens' PackageDescription [String]-extraSrcFiles f s = fmap (\x -> s { T.extraSrcFiles = x }) (f (T.extraSrcFiles s))-{-# INLINE extraSrcFiles #-}--extraTmpFiles :: Lens' PackageDescription [String]-extraTmpFiles f s = fmap (\x -> s { T.extraTmpFiles = x }) (f (T.extraTmpFiles s))-{-# INLINE extraTmpFiles #-}--extraDocFiles :: Lens' PackageDescription [String]-extraDocFiles f s = fmap (\x -> s { T.extraDocFiles = x }) (f (T.extraDocFiles s))-{-# INLINE extraDocFiles #-}---- | @since 3.0.0.0-allLibraries :: Traversal' PackageDescription Library-allLibraries f pd = mk <$> traverse f (T.library pd) <*> traverse f (T.subLibraries pd)-  where-    mk l ls = pd { T.library = l, T.subLibraries = ls }---- | @since 2.4-componentModules :: Monoid r => ComponentName -> Getting r PackageDescription [ModuleName]-componentModules cname = case cname of-    CLibName    name ->-      componentModules' name allLibraries             libName            explicitLibModules-    CFLibName   name ->-      componentModules' name (foreignLibs . traverse) foreignLibName     foreignLibModules-    CExeName    name ->-      componentModules' name (executables . traverse) exeName            exeModules-    CTestName   name ->-      componentModules' name (testSuites  . traverse) testName           testModules-    CBenchName  name ->-      componentModules' name (benchmarks  . traverse) benchmarkName      benchmarkModules-  where-    componentModules'-        :: (Eq name, Monoid r)-        => name-        -> Traversal' PackageDescription a-        -> Lens' a name-        -> (a -> [ModuleName])-        -> Getting r PackageDescription [ModuleName]-    componentModules' name pdL nameL modules =-        pdL-      . filtered ((== name) . view nameL)-      . getting modules--    filtered :: (a -> Bool) -> Traversal' a a-    filtered p f s = if p s then f s else pure s---- | @since 2.4-componentBuildInfo :: ComponentName -> Traversal' PackageDescription BuildInfo-componentBuildInfo cname = case cname of-    CLibName    name ->-      componentBuildInfo' name allLibraries             libName            libBuildInfo-    CFLibName   name ->-      componentBuildInfo' name (foreignLibs . traverse) foreignLibName     foreignLibBuildInfo-    CExeName    name ->-      componentBuildInfo' name (executables . traverse) exeName            exeBuildInfo-    CTestName   name ->-      componentBuildInfo' name (testSuites  . traverse) testName           testBuildInfo-    CBenchName  name ->-      componentBuildInfo' name (benchmarks  . traverse) benchmarkName      benchmarkBuildInfo-  where-    componentBuildInfo' :: Eq name-                        => name-                        -> Traversal' PackageDescription a-                        -> Lens' a name-                        -> Traversal' a BuildInfo-                        -> Traversal' PackageDescription BuildInfo-    componentBuildInfo' name pdL nameL biL =-        pdL-      . filtered ((== name) . view nameL)-      . biL--    filtered :: (a -> Bool) -> Traversal' a a-    filtered p f s = if p s then f s else pure s
− src/Distribution/Types/PackageId.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.Types.PackageId-  ( PackageIdentifier(..)-  , PackageId-  ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Parsec            (Parsec (..), simpleParsec)-import Distribution.Pretty-import Distribution.Types.PackageName-import Distribution.Version           (Version, nullVersion)--import qualified Data.List.NonEmpty              as NE-import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp---- | Type alias so we can use the shorter name PackageId.-type PackageId = PackageIdentifier---- | The name and version of a package.-data PackageIdentifier-    = PackageIdentifier {-        pkgName    :: PackageName, -- ^The name of this package, eg. foo-        pkgVersion :: Version -- ^the version of this package, eg 1.2-     }-     deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)--instance Binary PackageIdentifier-instance Structured PackageIdentifier--instance Pretty PackageIdentifier where-  pretty (PackageIdentifier n v)-    | v == nullVersion = pretty n -- if no version, don't show version.-    | otherwise        = pretty n <<>> Disp.char '-' <<>> pretty v---- |------ >>> simpleParsec "foo-bar-0" :: Maybe PackageIdentifier--- Just (PackageIdentifier {pkgName = PackageName "foo-bar", pkgVersion = mkVersion [0]})------ >>> simpleParsec "foo-bar" :: Maybe PackageIdentifier--- Just (PackageIdentifier {pkgName = PackageName "foo-bar", pkgVersion = mkVersion []})------ /Note:/ Stricter than 'Text' instance------ >>> simpleParsec "foo-bar-0-0" :: Maybe PackageIdentifier--- Nothing------ >>> simpleParsec "foo-bar.0" :: Maybe PackageIdentifier--- Nothing------ >>> simpleParsec "foo-bar.4-2" :: Maybe PackageIdentifier--- Nothing------ >>> simpleParsec "1.2.3" :: Maybe PackageIdentifier--- Nothing----instance Parsec PackageIdentifier where-  parsec = do-      xs' <- P.sepByNonEmpty component (P.char '-')-      (v, xs) <- case simpleParsec (NE.last xs') of-          Nothing -> return (nullVersion, toList xs') -- all components are version-          Just v  -> return (v, NE.init xs')-      if not (null xs) && all (\c ->  all (/= '.') c && not (all isDigit c)) xs-      then return $ PackageIdentifier (mkPackageName (intercalate  "-" xs)) v-      else fail "all digits or a dot in a portion of package name"-    where-      component = P.munch1 (\c ->  isAlphaNum c || c == '.')--instance NFData PackageIdentifier where-    rnf (PackageIdentifier name version) = rnf name `seq` rnf version
− src/Distribution/Types/PackageId/Lens.hs 
@@ -1,22 +0,0 @@-module Distribution.Types.PackageId.Lens (-    PackageIdentifier,-    module Distribution.Types.PackageId.Lens,-    ) where--import Distribution.Compat.Lens-import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Types.PackageId   (PackageIdentifier)-import Distribution.Types.PackageName (PackageName)-import Distribution.Version           (Version)--import qualified Distribution.Types.PackageId as T--pkgName :: Lens' PackageIdentifier PackageName-pkgName f s = fmap (\x -> s { T.pkgName = x }) (f (T.pkgName s))-{-# INLINE pkgName #-}--pkgVersion :: Lens' PackageIdentifier Version-pkgVersion f s = fmap (\x -> s { T.pkgVersion = x }) (f (T.pkgVersion s))-{-# INLINE pkgVersion #-}
− src/Distribution/Types/PackageName.hs 
@@ -1,73 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Types.PackageName-  ( PackageName-  , unPackageName, mkPackageName-  , unPackageNameST, mkPackageNameST-  ) where--import Prelude ()-import Distribution.Compat.Prelude-import Distribution.Utils.ShortText--import qualified Text.PrettyPrint as Disp-import Distribution.Pretty-import Distribution.Parsec---- | A package name.------ Use 'mkPackageName' and 'unPackageName' to convert from/to a--- 'String'.------ This type is opaque since @Cabal-2.0@------ @since 2.0.0.2-newtype PackageName = PackageName ShortText-    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)---- | Convert 'PackageName' to 'String'-unPackageName :: PackageName -> String-unPackageName (PackageName s) = fromShortText s---- | @since 3.4.0.0-unPackageNameST :: PackageName -> ShortText-unPackageNameST (PackageName s) = s---- | Construct a 'PackageName' from a 'String'------ 'mkPackageName' is the inverse to 'unPackageName'------ Note: No validations are performed to ensure that the resulting--- 'PackageName' is valid------ @since 2.0.0.2-mkPackageName :: String -> PackageName-mkPackageName = PackageName . toShortText---- | Construct a 'PackageName' from a 'ShortText'------ Note: No validations are performed to ensure that the resulting--- 'PackageName' is valid------ @since 3.4.0.0-mkPackageNameST :: ShortText -> PackageName-mkPackageNameST = PackageName---- | 'mkPackageName'------ @since 2.0.0.2-instance IsString PackageName where-  fromString = mkPackageName--instance Binary PackageName-instance Structured PackageName--instance Pretty PackageName where-  pretty = Disp.text . unPackageName--instance Parsec PackageName where-  parsec = mkPackageName <$> parsecUnqualComponentName--instance NFData PackageName where-    rnf (PackageName pkg) = rnf pkg
src/Distribution/Types/PackageName/Magic.hs view
@@ -11,9 +11,13 @@ nonExistentPackageThisIsCabalBug :: PackageName nonExistentPackageThisIsCabalBug = mkPackageName "nonexistent-package-this-is-a-cabal-bug" --- | Used by @cabal new-repl@ and @cabal new-run@+-- | Used by @cabal new-repl@, @cabal new-run@ and @cabal new-build@ fakePackageName :: PackageName fakePackageName = mkPackageName "fake-package"++-- | Used by @cabal new-run@ and @cabal new-build@+fakePackageCabalFileName :: FilePath+fakePackageCabalFileName = "fake-package.cabal"  -- | 'fakePackageName' with 'version0'. fakePackageId :: PackageId
− src/Distribution/Types/PackageVersionConstraint.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.Types.PackageVersionConstraint (-    PackageVersionConstraint(..),-    thisPackageVersionConstraint,-    simplifyPackageVersionConstraint,-) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty-import Distribution.Types.PackageId-import Distribution.Types.PackageName-import Distribution.Types.Version-import Distribution.Types.VersionRange.Internal-import Distribution.Version                     (simplifyVersionRange)--import qualified Distribution.Compat.CharParsing as P---- | A version constraint on a package. Different from 'ExeDependency' and--- 'Dependency' since it does not specify the need for a component, not even--- the main library.--- There are a few places in the codebase where 'Dependency' was used where--- 'PackageVersionConstraint' is not used instead (#5570).-data PackageVersionConstraint = PackageVersionConstraint PackageName VersionRange-                  deriving (Generic, Read, Show, Eq, Typeable, Data)--instance Binary PackageVersionConstraint-instance Structured PackageVersionConstraint-instance NFData PackageVersionConstraint where rnf = genericRnf--instance Pretty PackageVersionConstraint where-  -- Cannot do: PackageVersionConstraint have to be parseable-  -- as Dependency, due roundtrip problems. (e.g. talking to old ./Setup).-  ---  -- pretty (PackageVersionConstraint name (ThisVersion ver)) =-  --     pretty (PackageIdentifier name ver)-  pretty (PackageVersionConstraint name ver) =-      pretty name <+> pretty ver---- |------ >>> simpleParsec "foo" :: Maybe PackageVersionConstraint--- Just (PackageVersionConstraint (PackageName "foo") (OrLaterVersion (mkVersion [0])))------ >>> simpleParsec "foo >=2.0" :: Maybe PackageVersionConstraint--- Just (PackageVersionConstraint (PackageName "foo") (OrLaterVersion (mkVersion [2,0])))------ >>> simpleParsec "foo-2.0" :: Maybe PackageVersionConstraint--- Just (PackageVersionConstraint (PackageName "foo") (ThisVersion (mkVersion [2,0])))----instance Parsec PackageVersionConstraint where-  parsec = do-      PackageIdentifier name ver <- parsec-      if ver == nullVersion-      then do-          P.spaces-          vr <- parsec <|> return anyVersion-          P.spaces-          return (PackageVersionConstraint name vr)-      else-          pure (PackageVersionConstraint name (thisVersion ver))---- | @since 3.4.0.0-thisPackageVersionConstraint :: PackageIdentifier -> PackageVersionConstraint-thisPackageVersionConstraint (PackageIdentifier pn vr) =-    PackageVersionConstraint pn (thisVersion vr)---- | @since 3.4.0.0-simplifyPackageVersionConstraint :: PackageVersionConstraint -> PackageVersionConstraint-simplifyPackageVersionConstraint (PackageVersionConstraint pn vr) =-    PackageVersionConstraint pn (simplifyVersionRange vr)
+ src/Distribution/Types/ParStrat.hs view
@@ -0,0 +1,24 @@+module Distribution.Types.ParStrat where++-- | 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`).+    NumJobs (Maybe Int)+  | -- | `--semaphore`: use a system semaphore to control parallelism.+    UseSem sem+  | -- | No parallelism (neither `-jN` nor `--semaphore`, but could be `-j1`).+    Serial+  deriving (Show)++-- | Used by Cabal to indicate that we want to use this specific semaphore (created by cabal-install)+type ParStrat = ParStratX String++-- | Used by cabal-install to say we want to create a semaphore with N slots.+type ParStratInstall = ParStratX Int++-- | Determine if the parallelism strategy enables parallel builds.+isParallelBuild :: ParStratX n -> Bool+isParallelBuild Serial = False+isParallelBuild (NumJobs (Just 1)) = False+isParallelBuild (NumJobs _) = True+isParallelBuild UseSem{} = True
− src/Distribution/Types/PkgconfigDependency.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.Types.PkgconfigDependency-  ( PkgconfigDependency(..)-  ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Types.PkgconfigName-import Distribution.Types.PkgconfigVersionRange--import Distribution.Parsec-import Distribution.Pretty--import qualified Distribution.Compat.CharParsing as P---- | Describes a dependency on a pkg-config library------ @since 2.0.0.2-data PkgconfigDependency = PkgconfigDependency-                           PkgconfigName-                           PkgconfigVersionRange-                         deriving (Generic, Read, Show, Eq, Typeable, Data)--instance Binary PkgconfigDependency-instance Structured PkgconfigDependency-instance NFData PkgconfigDependency where rnf = genericRnf--instance Pretty PkgconfigDependency where-    pretty (PkgconfigDependency name PcAnyVersion) = pretty name-    pretty (PkgconfigDependency name ver)          = pretty name <+> pretty ver--instance Parsec PkgconfigDependency where-    parsec = do-        name <- parsec-        P.spaces-        verRange <- parsec <|> pure anyPkgconfigVersion-        pure $ PkgconfigDependency name verRange
− src/Distribution/Types/PkgconfigName.hs 
@@ -1,68 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Types.PkgconfigName-  ( PkgconfigName, unPkgconfigName, mkPkgconfigName-  ) where--import Prelude ()-import Distribution.Compat.Prelude-import Distribution.Utils.ShortText--import Distribution.Pretty-import Distribution.Parsec--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp---- | A pkg-config library name------ This is parsed as any valid argument to the pkg-config utility.------ @since 2.0.0.2-newtype PkgconfigName = PkgconfigName ShortText-    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)---- | Convert 'PkgconfigName' to 'String'------ @since 2.0.0.2-unPkgconfigName :: PkgconfigName -> String-unPkgconfigName (PkgconfigName s) = fromShortText s---- | Construct a 'PkgconfigName' from a 'String'------ 'mkPkgconfigName' is the inverse to 'unPkgconfigName'------ Note: No validations are performed to ensure that the resulting--- 'PkgconfigName' is valid------ @since 2.0.0.2-mkPkgconfigName :: String -> PkgconfigName-mkPkgconfigName = PkgconfigName . toShortText---- | 'mkPkgconfigName'------ @since 2.0.0.2-instance IsString PkgconfigName where-    fromString = mkPkgconfigName--instance Binary PkgconfigName-instance Structured PkgconfigName---- pkg-config allows versions and other letters in package names, eg--- "gtk+-2.0" is a valid pkg-config package _name_.  It then has a package--- version number like 2.10.13-instance Pretty PkgconfigName where-  pretty = Disp.text . unPkgconfigName--instance Parsec PkgconfigName where-    parsec = mkPkgconfigName <$> P.munch1 isNameChar where-        -- https://gitlab.haskell.org/ghc/ghc/issues/17752-        isNameChar '-' = True-        isNameChar '_' = True-        isNameChar '.' = True-        isNameChar '+' = True-        isNameChar c   = isAlphaNum c--instance NFData PkgconfigName where-    rnf (PkgconfigName pkg) = rnf pkg
− src/Distribution/Types/PkgconfigVersion.hs 
@@ -1,119 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}--- @since 3.0-module Distribution.Types.PkgconfigVersion (-    PkgconfigVersion (..),-    rpmvercmp,-    ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty-import Distribution.Utils.Generic (isAsciiAlphaNum)--import qualified Data.ByteString                 as BS-import qualified Data.ByteString.Char8           as BS8-import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as PP---- | @pkg-config@ versions.------ In fact, this can be arbitrary 'BS.ByteString',--- but 'Parsec' instance is a little pickier.------ @since 3.0-newtype PkgconfigVersion = PkgconfigVersion BS.ByteString-  deriving (Generic, Read, Show, Typeable, Data)--instance Eq PkgconfigVersion where-    PkgconfigVersion a == PkgconfigVersion b = rpmvercmp a b == EQ--instance Ord PkgconfigVersion where-    PkgconfigVersion a `compare` PkgconfigVersion b = rpmvercmp a b--instance Binary PkgconfigVersion-instance Structured PkgconfigVersion-instance NFData PkgconfigVersion where rnf = genericRnf--instance Pretty PkgconfigVersion where-    pretty (PkgconfigVersion bs) = PP.text (BS8.unpack bs)---- |------ >>> simpleParsec "1.0.2n" :: Maybe PkgconfigVersion--- Just (PkgconfigVersion "1.0.2n")------ >>> simpleParsec "0.3.5+ds" :: Maybe PkgconfigVersion--- Nothing----instance Parsec PkgconfigVersion where-    parsec = PkgconfigVersion . BS8.pack <$> P.munch1 predicate where-        predicate c = isAsciiAlphaNum c || c == '.' || c == '-'------------------------------------------------------------------------------------ rmpvercmp - pure Haskell implementation------------------------------------------------------------------------------------ | Compare two version strings as @pkg-config@ would compare them.------ @since 3.0-rpmvercmp :: BS.ByteString -> BS.ByteString -> Ordering-rpmvercmp a b = go0 (BS.unpack a) (BS.unpack b)-  where-    go0 :: [Word8] -> [Word8] -> Ordering-    -- if there is _any_ trailing "garbage", it seems to affect result-    -- https://github.com/haskell/cabal/issues/6805-    go0 [] [] = EQ-    go0 [] _  = LT-    go0 _  [] = GT-    go0 xs ys = go1 (dropNonAlnum8 xs) (dropNonAlnum8 ys)--    go1 :: [Word8] -> [Word8] -> Ordering-    go1 [] [] = EQ-    go1 [] _  = LT-    go1 _  [] = GT-    go1 xs@(x:_) ys-      | isDigit8 x =-          let (xs1, xs2) = span isDigit8 xs-              (ys1, ys2) = span isDigit8 ys-            -- numeric segments are always newer than alpha segments-          in if null ys1-             then GT-             else compareInt xs1 ys1 <> go0 xs2 ys2--      -- isAlpha-      | otherwise =-          let (xs1, xs2) = span isAlpha8 xs-              (ys1, ys2) = span isAlpha8 ys-          in if null ys1-             then LT-             else compareStr xs1 ys1 <> go0 xs2 ys2---- compare as numbers-compareInt :: [Word8] -> [Word8] -> Ordering-compareInt xs ys =-    -- whichever number has more digits wins-    compare (length xs') (length ys') <>-    -- equal length: use per character compare, "strcmp"-    compare xs' ys'-  where-    -- drop  leading zeros-    xs' = dropWhile (== 0x30) xs-    ys' = dropWhile (== 0x30) ys---- strcmp-compareStr :: [Word8] -> [Word8] -> Ordering-compareStr = compare--dropNonAlnum8 :: [Word8] -> [Word8]-dropNonAlnum8 = dropWhile (\w -> not (isDigit8 w || isAlpha8 w))--isDigit8 :: Word8 -> Bool-isDigit8 w = 0x30 <= w && w <= 0x39--isAlpha8 :: Word8 -> Bool-isAlpha8 w = (0x41 <= w && w <= 0x5A) || (0x61 <= w && w <= 0x7A)--
− src/Distribution/Types/PkgconfigVersionRange.hs 
@@ -1,161 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.Types.PkgconfigVersionRange (-    PkgconfigVersionRange (..),-    anyPkgconfigVersion,-    isAnyPkgconfigVersion,-    withinPkgconfigVersionRange,-    -- * Internal-    versionToPkgconfigVersion,-    versionRangeToPkgconfigVersionRange,-    ) where--import Distribution.Compat.Prelude-import Prelude ()--import Distribution.CabalSpecVersion-import Distribution.Parsec-import Distribution.Pretty-import Distribution.Types.PkgconfigVersion-import Distribution.Types.Version-import Distribution.Types.VersionInterval-import Distribution.Types.VersionRange--import qualified Data.ByteString.Char8           as BS8-import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as PP---- | @since 3.0-data PkgconfigVersionRange-  = PcAnyVersion-  | PcThisVersion            PkgconfigVersion -- = version-  | PcLaterVersion           PkgconfigVersion -- > version  (NB. not >=)-  | PcEarlierVersion         PkgconfigVersion -- < version-  | PcOrLaterVersion         PkgconfigVersion -- >= version-  | PcOrEarlierVersion       PkgconfigVersion -- =< version-  | PcUnionVersionRanges     PkgconfigVersionRange PkgconfigVersionRange-  | PcIntersectVersionRanges PkgconfigVersionRange PkgconfigVersionRange-  deriving (Generic, Read, Show, Eq, Typeable, Data)--instance Binary PkgconfigVersionRange-instance Structured PkgconfigVersionRange-instance NFData PkgconfigVersionRange where rnf = genericRnf--instance Pretty PkgconfigVersionRange where-    pretty = pp 0  where-        pp :: Int -> PkgconfigVersionRange -> PP.Doc-        pp _ PcAnyVersion           = PP.text "-any"-        pp _ (PcThisVersion v)      = PP.text "==" <<>> pretty v-        pp _ (PcLaterVersion v)     = PP.text ">" <<>> pretty v-        pp _ (PcEarlierVersion v)   = PP.text "<" <<>> pretty v-        pp _ (PcOrLaterVersion v)   = PP.text ">=" <<>> pretty v-        pp _ (PcOrEarlierVersion v) = PP.text "<=" <<>> pretty v--        pp d (PcUnionVersionRanges v u) = parens (d >= 1) $-            pp 1 v PP.<+> PP.text "||" PP.<+> pp 0 u-        pp d (PcIntersectVersionRanges v u) = parens (d >= 2) $-            pp 2 v PP.<+> PP.text "&&" PP.<+> pp 1 u--        parens True  = PP.parens-        parens False = id--instance Parsec PkgconfigVersionRange where-    -- note: the wildcard is used in some places, e.g-    -- http://hackage.haskell.org/package/bindings-libzip-0.10.1/bindings-libzip.cabal-    ---    -- however, in the presence of alphanumerics etc. lax version parser,-    -- wildcard is ill-specified--    parsec = do-        csv <- askCabalSpecVersion-        if csv >= CabalSpecV3_0-        then pkgconfigParser-        else versionRangeToPkgconfigVersionRange <$> versionRangeParser P.integral csv---- "modern" parser of @pkg-config@ package versions.-pkgconfigParser :: CabalParsing m => m PkgconfigVersionRange-pkgconfigParser = P.spaces >> expr where-    -- every parser here eats trailing space-    expr = do-        ts <- term `P.sepByNonEmpty` (P.string "||" >> P.spaces)-        return $ foldr1 PcUnionVersionRanges ts--    term = do-        fs <- factor `P.sepByNonEmpty` (P.string "&&" >> P.spaces)-        return $ foldr1 PcIntersectVersionRanges fs--    factor = parens expr <|> prim--    prim = do-        op <- P.munch1 isOpChar P.<?> "operator"-        case op of-            "-"  -> anyPkgconfigVersion <$ (P.string "any" *> P.spaces)--            "==" -> afterOp PcThisVersion-            ">"  -> afterOp PcLaterVersion-            "<"  -> afterOp PcEarlierVersion-            ">=" -> afterOp PcOrLaterVersion-            "<=" -> afterOp PcOrEarlierVersion--            _ -> P.unexpected $ "Unknown version operator " ++ show op--    -- https://gitlab.haskell.org/ghc/ghc/issues/17752-    isOpChar '<' = True-    isOpChar '=' = True-    isOpChar '>' = True-    isOpChar '^' = True-    isOpChar '-' = True-    isOpChar _   = False--    afterOp f = do-        P.spaces-        v <- parsec-        P.spaces-        return (f v)--    parens = P.between-        ((P.char '(' P.<?> "opening paren") >> P.spaces)-        (P.char ')' >> P.spaces)--anyPkgconfigVersion :: PkgconfigVersionRange-anyPkgconfigVersion = PcAnyVersion---- | TODO: this is not precise, but used only to prettify output.-isAnyPkgconfigVersion :: PkgconfigVersionRange -> Bool-isAnyPkgconfigVersion = (== PcAnyVersion)--withinPkgconfigVersionRange :: PkgconfigVersion -> PkgconfigVersionRange -> Bool-withinPkgconfigVersionRange v = go where-    go PcAnyVersion                   = True-    go (PcThisVersion u)              = v == u-    go (PcLaterVersion u)             = v > u-    go (PcEarlierVersion u)           = v < u-    go (PcOrLaterVersion u)           = v >= u-    go (PcOrEarlierVersion u)         = v <= u-    go (PcUnionVersionRanges a b)     = go a || go b-    go (PcIntersectVersionRanges a b) = go a && go b------------------------------------------------------------------------------------ Conversion----------------------------------------------------------------------------------versionToPkgconfigVersion :: Version -> PkgconfigVersion-versionToPkgconfigVersion = PkgconfigVersion . BS8.pack . prettyShow--versionRangeToPkgconfigVersionRange :: VersionRange -> PkgconfigVersionRange-versionRangeToPkgconfigVersionRange vr-    | isAnyVersion vr-    = PcAnyVersion-    | otherwise-    = case asVersionIntervals vr of-        []     -> PcEarlierVersion (PkgconfigVersion (BS8.pack "0"))-        (i:is) -> foldl (\r j -> PcUnionVersionRanges r (conv j)) (conv i) is-  where-    conv (VersionInterval (LowerBound v b) NoUpperBound)     = convL v b-    conv (VersionInterval (LowerBound v b) (UpperBound u c)) = PcIntersectVersionRanges (convL v b) (convU u c)--    convL v ExclusiveBound = PcLaterVersion (versionToPkgconfigVersion v)-    convL v InclusiveBound = PcOrLaterVersion (versionToPkgconfigVersion v)--    convU v ExclusiveBound = PcEarlierVersion (versionToPkgconfigVersion v)-    convU v InclusiveBound = PcOrEarlierVersion (versionToPkgconfigVersion v)
− src/Distribution/Types/SetupBuildInfo.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Distribution.Types.SetupBuildInfo (-    SetupBuildInfo(..)-) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Types.Dependency---- ------------------------------------------------------------------------------ The SetupBuildInfo type---- One can see this as a very cut-down version of BuildInfo below.--- To keep things simple for tools that compile Setup.hs we limit the--- options authors can specify to just Haskell package dependencies.--data SetupBuildInfo = SetupBuildInfo-    { setupDepends        :: [Dependency]-    , defaultSetupDepends :: Bool-        -- ^ Is this a default 'custom-setup' section added by the cabal-install-        -- code (as opposed to user-provided)? This field is only used-        -- internally, and doesn't correspond to anything in the .cabal-        -- file. See #3199.-    }-    deriving (Generic, Show, Eq, Read, Typeable, Data)--instance Binary SetupBuildInfo-instance Structured SetupBuildInfo-instance NFData SetupBuildInfo where rnf = genericRnf--instance Monoid SetupBuildInfo where-    mempty  = SetupBuildInfo [] False-    mappend = (<>)--instance Semigroup SetupBuildInfo where-    a <> b = SetupBuildInfo-        (setupDepends a <> setupDepends b)-        (defaultSetupDepends a || defaultSetupDepends b)
− src/Distribution/Types/SetupBuildInfo/Lens.hs 
@@ -1,21 +0,0 @@-module Distribution.Types.SetupBuildInfo.Lens (-    SetupBuildInfo,-    module Distribution.Types.SetupBuildInfo.Lens,-    ) where--import Distribution.Compat.Lens-import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Types.Dependency     (Dependency)-import Distribution.Types.SetupBuildInfo (SetupBuildInfo)--import qualified Distribution.Types.SetupBuildInfo as T--setupDepends :: Lens' SetupBuildInfo [Dependency]-setupDepends f s = fmap (\x -> s { T.setupDepends = x }) (f (T.setupDepends s))-{-# INLINE setupDepends #-}--defaultSetupDepends :: Lens' SetupBuildInfo Bool-defaultSetupDepends f s = fmap (\x -> s { T.defaultSetupDepends = x }) (f (T.defaultSetupDepends s))-{-# INLINE defaultSetupDepends #-}
− src/Distribution/Types/SourceRepo.hs 
@@ -1,201 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Distribution.Types.SourceRepo (-    SourceRepo(..),-    RepoKind(..),-    RepoType(..),-    KnownRepoType (..),-    knownRepoTypes,-    emptySourceRepo,-    classifyRepoType,-    classifyRepoKind,-  ) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Utils.Generic (lowercase)--import Distribution.Pretty-import Distribution.Parsec--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp-import qualified Data.Map.Strict as M---- --------------------------------------------------------------- * Source repos--- ---------------------------------------------------------------- | Information about the source revision control system for a package.------ When specifying a repo it is useful to know the meaning or intention of the--- information as doing so enables automation. There are two obvious common--- purposes: one is to find the repo for the latest development version, the--- other is to find the repo for this specific release. The 'ReopKind'--- specifies which one we mean (or another custom one).------ A package can specify one or the other kind or both. Most will specify just--- a head repo but some may want to specify a repo to reconstruct the sources--- for this package release.------ The required information is the 'RepoType' which tells us if it's using--- 'Darcs', 'Git' for example. The 'repoLocation' and other details are--- interpreted according to the repo type.----data SourceRepo = SourceRepo {-  -- | The kind of repo. This field is required.-  repoKind     :: RepoKind,--  -- | The type of the source repository system for this repo, eg 'Darcs' or-  -- 'Git'. This field is required.-  repoType     :: Maybe RepoType,--  -- | The location of the repository. For most 'RepoType's this is a URL.-  -- This field is required.-  repoLocation :: Maybe String,--  -- | 'CVS' can put multiple \"modules\" on one server and requires a-  -- module name in addition to the location to identify a particular repo.-  -- Logically this is part of the location but unfortunately has to be-  -- specified separately. This field is required for the 'CVS' 'RepoType' and-  -- should not be given otherwise.-  repoModule   :: Maybe String,--  -- | The name or identifier of the branch, if any. Many source control-  -- systems have the notion of multiple branches in a repo that exist in the-  -- same location. For example 'Git' and 'CVS' use this while systems like-  -- 'Darcs' use different locations for different branches. This field is-  -- optional but should be used if necessary to identify the sources,-  -- especially for the 'RepoThis' repo kind.-  repoBranch   :: Maybe String,--  -- | The tag identify a particular state of the repository. This should be-  -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind.-  ---  repoTag      :: Maybe String,--  -- | Some repositories contain multiple projects in different subdirectories-  -- This field specifies the subdirectory where this packages sources can be-  -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted-  -- relative to the root of the repository. This field is optional. If not-  -- given the default is \".\" ie no subdirectory.-  repoSubdir   :: Maybe FilePath-}-  deriving (Eq, Ord, Generic, Read, Show, Typeable, Data)--emptySourceRepo :: RepoKind -> SourceRepo-emptySourceRepo kind = SourceRepo-    { repoKind     = kind-    , repoType     = Nothing-    , repoLocation = Nothing-    , repoModule   = Nothing-    , repoBranch   = Nothing-    , repoTag      = Nothing-    , repoSubdir   = Nothing-    }--instance Binary SourceRepo-instance Structured SourceRepo-instance NFData SourceRepo where rnf = genericRnf---- | What this repo info is for, what it represents.----data RepoKind =-    -- | The repository for the \"head\" or development version of the project.-    -- This repo is where we should track the latest development activity or-    -- the usual repo people should get to contribute patches.-    RepoHead--    -- | The repository containing the sources for this exact package version-    -- or release. For this kind of repo a tag should be given to give enough-    -- information to re-create the exact sources.-  | RepoThis--  | RepoKindUnknown String-  deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)--instance Binary RepoKind-instance Structured RepoKind-instance NFData RepoKind where rnf = genericRnf---- | An enumeration of common source control systems. The fields used in the--- 'SourceRepo' depend on the type of repo. The tools and methods used to--- obtain and track the repo depend on the repo type.----data KnownRepoType = Darcs | Git | SVN | CVS-                   | Mercurial | GnuArch | Bazaar | Monotone-                   | Pijul -- ^ @since 3.4.0.0-  deriving (Eq, Generic, Ord, Read, Show, Typeable, Data, Enum, Bounded)--instance Binary KnownRepoType-instance Structured KnownRepoType-instance NFData KnownRepoType where rnf = genericRnf--instance Parsec KnownRepoType where-  parsec = do-    str <- P.munch1 isIdent-    maybe-      (P.unexpected $ "Could not parse KnownRepoType from " ++ str)-      return-      (M.lookup str knownRepoTypeMap)--instance Pretty KnownRepoType where-  pretty = Disp.text . lowercase . show--data RepoType = KnownRepoType KnownRepoType-              | OtherRepoType String-  deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)--instance Binary RepoType-instance Structured RepoType-instance NFData RepoType where rnf = genericRnf--knownRepoTypes :: [KnownRepoType]-knownRepoTypes = [minBound .. maxBound]--repoTypeAliases :: KnownRepoType -> [String]-repoTypeAliases Bazaar    = ["bzr"]-repoTypeAliases Mercurial = ["hg"]-repoTypeAliases GnuArch   = ["arch"]-repoTypeAliases _         = []--instance Pretty RepoKind where-  pretty RepoHead                = Disp.text "head"-  pretty RepoThis                = Disp.text "this"-  pretty (RepoKindUnknown other) = Disp.text other--instance Parsec RepoKind where-  parsec = classifyRepoKind <$> P.munch1 isIdent--classifyRepoKind :: String -> RepoKind-classifyRepoKind name = case lowercase name of-  "head" -> RepoHead-  "this" -> RepoThis-  _      -> RepoKindUnknown name--instance Parsec RepoType where-  parsec = classifyRepoType <$> P.munch1 isIdent--instance Pretty RepoType where-  pretty (OtherRepoType other) = Disp.text other-  pretty (KnownRepoType t) = pretty t--classifyRepoType :: String -> RepoType-classifyRepoType s =-  maybe-    (OtherRepoType s)-    KnownRepoType-    (M.lookup (lowercase s) knownRepoTypeMap)--knownRepoTypeMap :: Map String KnownRepoType-knownRepoTypeMap =-  M.fromList-    [ (name, repoType')-      | repoType' <- knownRepoTypes-      , name <- prettyShow repoType' : repoTypeAliases repoType'-    ]--isIdent :: Char -> Bool-isIdent c = isAlphaNum c || c == '_' || c == '-'
− src/Distribution/Types/SourceRepo/Lens.hs 
@@ -1,39 +0,0 @@-module Distribution.Types.SourceRepo.Lens (-    T.SourceRepo,-    module Distribution.Types.SourceRepo.Lens,-    ) where--import Prelude()-import Distribution.Compat.Prelude-import Distribution.Compat.Lens--import Distribution.Types.SourceRepo (SourceRepo, RepoKind, RepoType)-import qualified Distribution.Types.SourceRepo as T--repoKind :: Lens' SourceRepo RepoKind-repoKind f s = fmap (\x -> s { T.repoKind = x }) (f (T.repoKind s))-{-# INLINE repoKind #-}--repoType :: Lens' SourceRepo (Maybe RepoType)-repoType f s = fmap (\x -> s { T.repoType = x }) (f (T.repoType s))-{-# INLINE repoType #-}--repoLocation :: Lens' SourceRepo (Maybe String)-repoLocation f s = fmap (\x -> s { T.repoLocation = x }) (f (T.repoLocation s))-{-# INLINE repoLocation #-}--repoModule :: Lens' SourceRepo (Maybe String)-repoModule f s = fmap (\x -> s { T.repoModule = x }) (f (T.repoModule s))-{-# INLINE repoModule #-}--repoBranch :: Lens' SourceRepo (Maybe String)-repoBranch f s = fmap (\x -> s { T.repoBranch = x }) (f (T.repoBranch s))-{-# INLINE repoBranch #-}--repoTag :: Lens' SourceRepo (Maybe String)-repoTag f s = fmap (\x -> s { T.repoTag = x }) (f (T.repoTag s))-{-# INLINE repoTag #-}--repoSubdir :: Lens' SourceRepo (Maybe FilePath)-repoSubdir f s = fmap (\x -> s { T.repoSubdir = x }) (f (T.repoSubdir s))-{-# INLINE repoSubdir #-}
src/Distribution/Types/TargetInfo.hs view
@@ -1,33 +1,39 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-}-module Distribution.Types.TargetInfo (-    TargetInfo(..)-) where -import Prelude ()+module Distribution.Types.TargetInfo+  ( TargetInfo (..)+  ) where+ import Distribution.Compat.Prelude+import Prelude () -import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.Component+import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.UnitId -import Distribution.Compat.Graph (IsNode(..))+import Distribution.Compat.Graph (IsNode (..))  -- | The 'TargetInfo' contains all the information necessary to build a -- specific target (e.g., component/module/file) in a package.  In -- principle, one can get the 'Component' from a -- 'ComponentLocalBuildInfo' and 'LocalBuildInfo', but it is much more -- convenient to have the component in hand.-data TargetInfo = TargetInfo {-        targetCLBI      :: ComponentLocalBuildInfo,-        targetComponent :: Component-        -- TODO: BuildTargets supporting parsing these is dumb,-        -- we don't have support for compiling single modules or-        -- file paths. Accommodating it now is premature-        -- generalization.  Figure it out later.-        -- targetSub       :: Maybe (Either ModuleName FilePath)-    }+data TargetInfo = TargetInfo+  { targetCLBI :: ComponentLocalBuildInfo+  , targetComponent :: Component+  -- TODO: BuildTargets supporting parsing these is dumb,+  -- we don't have support for compiling single modules or+  -- file paths. Accommodating it now is premature+  -- generalization.  Figure it out later.+  -- targetSub       :: Maybe (Either ModuleName FilePath)+  }+  deriving (Generic, Show) +instance Binary TargetInfo+instance Structured TargetInfo+ instance IsNode TargetInfo where-    type Key TargetInfo = UnitId-    nodeKey       = nodeKey       . targetCLBI-    nodeNeighbors = nodeNeighbors . targetCLBI+  type Key TargetInfo = UnitId+  nodeKey = nodeKey . targetCLBI+  nodeNeighbors = nodeNeighbors . targetCLBI
− src/Distribution/Types/TestSuite.hs 
@@ -1,83 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Distribution.Types.TestSuite (-    TestSuite(..),-    emptyTestSuite,-    testType,-    testModules,-    testModulesAutogen-) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Types.BuildInfo-import Distribution.Types.TestType-import Distribution.Types.TestSuiteInterface-import Distribution.Types.UnqualComponentName--import Distribution.ModuleName--import qualified Distribution.Types.BuildInfo.Lens as L---- | A \"test-suite\" stanza in a cabal file.----data TestSuite = TestSuite {-        testName      :: UnqualComponentName,-        testInterface :: TestSuiteInterface,-        testBuildInfo :: BuildInfo-    }-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance L.HasBuildInfo TestSuite where-    buildInfo f l = (\x -> l { testBuildInfo = x }) <$> f (testBuildInfo l)--instance Binary TestSuite-instance Structured TestSuite--instance NFData TestSuite where rnf = genericRnf--instance Monoid TestSuite where-    mempty = TestSuite {-        testName      = mempty,-        testInterface = mempty,-        testBuildInfo = mempty-    }-    mappend = (<>)--instance Semigroup TestSuite where-    a <> b = TestSuite {-        testName      = combine' testName,-        testInterface = combine  testInterface,-        testBuildInfo = combine  testBuildInfo-    }-        where combine  field = field a `mappend` field b-              combine' field = case ( unUnqualComponentName $ field a-                                    , unUnqualComponentName $ field b) of-                        ("", _) -> field b-                        (_, "") -> field a-                        (x, y) -> error $ "Ambiguous values for test field: '"-                            ++ x ++ "' and '" ++ y ++ "'"--emptyTestSuite :: TestSuite-emptyTestSuite = mempty---testType :: TestSuite -> TestType-testType test = case testInterface test of-  TestSuiteExeV10 ver _         -> TestTypeExe ver-  TestSuiteLibV09 ver _         -> TestTypeLib ver-  TestSuiteUnsupported testtype -> testtype---- | Get all the module names from a test suite.-testModules :: TestSuite -> [ModuleName]-testModules test = (case testInterface test of-                     TestSuiteLibV09 _ m -> [m]-                     _                   -> [])-                ++ otherModules (testBuildInfo test)---- | Get all the auto generated module names from a test suite.--- This are a subset of 'testModules'.-testModulesAutogen :: TestSuite -> [ModuleName]-testModulesAutogen test = autogenModules (testBuildInfo test)
− src/Distribution/Types/TestSuite/Lens.hs 
@@ -1,27 +0,0 @@-module Distribution.Types.TestSuite.Lens (-    TestSuite,-    module Distribution.Types.TestSuite.Lens,-    ) where--import Distribution.Compat.Lens-import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Types.BuildInfo           (BuildInfo)-import Distribution.Types.TestSuite           (TestSuite)-import Distribution.Types.TestSuiteInterface  (TestSuiteInterface)-import Distribution.Types.UnqualComponentName (UnqualComponentName)--import qualified Distribution.Types.TestSuite as T--testName :: Lens' TestSuite UnqualComponentName-testName f s = fmap (\x -> s { T.testName = x }) (f (T.testName s))-{-# INLINE testName #-}--testInterface :: Lens' TestSuite TestSuiteInterface-testInterface f s = fmap (\x -> s { T.testInterface = x }) (f (T.testInterface s))-{-# INLINE testInterface #-}--testBuildInfo :: Lens' TestSuite BuildInfo-testBuildInfo f s = fmap (\x -> s { T.testBuildInfo = x }) (f (T.testBuildInfo s))-{-# INLINE testBuildInfo #-}
− src/Distribution/Types/TestSuiteInterface.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Distribution.Types.TestSuiteInterface (-    TestSuiteInterface(..),-) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Types.TestType-import Distribution.ModuleName-import Distribution.Version---- | The test suite interfaces that are currently defined. Each test suite must--- specify which interface it supports.------ More interfaces may be defined in future, either new revisions or totally--- new interfaces.----data TestSuiteInterface =--     -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form-     -- of an executable. It returns a zero exit code for success, non-zero for-     -- failure. The stdout and stderr channels may be logged. It takes no-     -- command line parameters and nothing on stdin.-     ---     TestSuiteExeV10 Version FilePath--     -- | Test interface \"detailed-0.9\". The test-suite takes the form of a-     -- library containing a designated module that exports \"tests :: [Test]\".-     ---   | TestSuiteLibV09 Version ModuleName--     -- | A test suite that does not conform to one of the above interfaces for-     -- the given reason (e.g. unknown test type).-     ---   | TestSuiteUnsupported TestType-   deriving (Eq, Generic, Read, Show, Typeable, Data)--instance Binary TestSuiteInterface-instance Structured TestSuiteInterface--instance NFData TestSuiteInterface where rnf = genericRnf--instance Monoid TestSuiteInterface where-    mempty  =  TestSuiteUnsupported (TestTypeUnknown mempty nullVersion)-    mappend = (<>)--instance Semigroup TestSuiteInterface where-    a <> (TestSuiteUnsupported _) = a-    _ <> b                        = b
− src/Distribution/Types/TestType.hs 
@@ -1,43 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE OverloadedStrings  #-}--module Distribution.Types.TestType (-    TestType(..),-    knownTestTypes,-) where--import Distribution.Compat.Prelude-import Distribution.Version-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty-import Text.PrettyPrint    (char, text)---- | The \"test-type\" field in the test suite stanza.----data TestType = TestTypeExe Version     -- ^ \"type: exitcode-stdio-x.y\"-              | TestTypeLib Version     -- ^ \"type: detailed-x.y\"-              | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\"-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary TestType-instance Structured TestType--instance NFData TestType where rnf = genericRnf--knownTestTypes :: [TestType]-knownTestTypes = [ TestTypeExe (mkVersion [1,0])-                 , TestTypeLib (mkVersion [0,9]) ]--instance Pretty TestType where-  pretty (TestTypeExe ver)          = text "exitcode-stdio-" <<>> pretty ver-  pretty (TestTypeLib ver)          = text "detailed-"       <<>> pretty ver-  pretty (TestTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver--instance Parsec TestType where-  parsec = parsecStandard $ \ver name -> case name of-      "exitcode-stdio" -> TestTypeExe ver-      "detailed"       -> TestTypeLib ver-      _                -> TestTypeUnknown name ver
− src/Distribution/Types/UnitId.hs 
@@ -1,134 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleContexts #-}--module Distribution.Types.UnitId-  ( UnitId, unUnitId, mkUnitId-  , DefUnitId-  , unsafeMkDefUnitId-  , unDefUnitId-  , newSimpleUnitId-  , mkLegacyUnitId-  , getHSLibraryName-  ) where--import Prelude ()-import Distribution.Compat.Prelude-import Distribution.Utils.ShortText--import qualified Distribution.Compat.CharParsing as P-import Distribution.Pretty-import Distribution.Parsec-import Distribution.Types.ComponentId-import Distribution.Types.PackageId--import Text.PrettyPrint (text)---- | A unit identifier identifies a (possibly instantiated)--- package/component that can be installed the installed package--- database.  There are several types of components that can be--- installed:------  * A traditional library with no holes, so that 'unitIdHash'---    is @Nothing@.  In the absence of Backpack, 'UnitId'---    is the same as a 'ComponentId'.------  * An indefinite, Backpack library with holes.  In this case,---    'unitIdHash' is still @Nothing@, but in the install,---    there are only interfaces, no compiled objects.------  * An instantiated Backpack library with all the holes---    filled in.  'unitIdHash' is a @Just@ a hash of the---    instantiating mapping.------ A unit is a component plus the additional information on how the--- holes are filled in. Thus there is a one to many relationship: for a--- particular component there are many different ways of filling in the--- holes, and each different combination is a unit (and has a separate--- 'UnitId').------ 'UnitId' is distinct from 'OpenUnitId', in that it is always--- installed, whereas 'OpenUnitId' are intermediate unit identities--- that arise during mixin linking, and don't necessarily correspond--- to any actually installed unit.  Since the mapping is not actually--- recorded in a 'UnitId', you can't actually substitute over them--- (but you can substitute over 'OpenUnitId').  See also--- "Distribution.Backpack.FullUnitId" for a mechanism for expanding an--- instantiated 'UnitId' to retrieve its mapping.------ Backwards compatibility note: if you need to get the string--- representation of a UnitId to pass, e.g., as a @-package-id@--- flag, use the 'display' function, which will work on all--- versions of Cabal.----newtype UnitId = UnitId ShortText-  deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, NFData)--instance Binary UnitId-instance Structured UnitId---- | The textual format for 'UnitId' coincides with the format--- GHC accepts for @-package-id@.----instance Pretty UnitId where-    pretty = text . unUnitId---- | The textual format for 'UnitId' coincides with the format--- GHC accepts for @-package-id@.----instance Parsec UnitId where-    parsec = mkUnitId <$> P.munch1 isUnitChar where-        -- https://gitlab.haskell.org/ghc/ghc/issues/17752-        isUnitChar '-' = True-        isUnitChar '_' = True-        isUnitChar '.' = True-        isUnitChar '+' = True-        isUnitChar c   = isAlphaNum c---- | If you need backwards compatibility, consider using 'display'--- instead, which is supported by all versions of Cabal.----unUnitId :: UnitId -> String-unUnitId (UnitId s) = fromShortText s--mkUnitId :: String -> UnitId-mkUnitId = UnitId . toShortText---- | 'mkUnitId'------ @since 2.0.0.2-instance IsString UnitId where-    fromString = mkUnitId---- | Create a unit identity with no associated hash directly--- from a 'ComponentId'.-newSimpleUnitId :: ComponentId -> UnitId-newSimpleUnitId = mkUnitId . unComponentId---- | Make an old-style UnitId from a package identifier.--- Assumed to be for the public library-mkLegacyUnitId :: PackageId -> UnitId-mkLegacyUnitId = newSimpleUnitId . mkComponentId . prettyShow---- | Returns library name prefixed with HS, suitable for filenames-getHSLibraryName :: UnitId -> String-getHSLibraryName uid = "HS" ++ prettyShow uid---- | A 'UnitId' for a definite package.  The 'DefUnitId' invariant says--- that a 'UnitId' identified this way is definite; i.e., it has no--- unfilled holes.-newtype DefUnitId = DefUnitId { unDefUnitId :: UnitId }-  deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Pretty)--instance Structured DefUnitId---- Workaround for a GHC 8.0.1 bug, see--- https://github.com/haskell/cabal/issues/4793#issuecomment-334258288-instance Parsec DefUnitId where-  parsec = DefUnitId <$> parsec---- | Unsafely create a 'DefUnitId' from a 'UnitId'.  Your responsibility--- is to ensure that the 'DefUnitId' invariant holds.-unsafeMkDefUnitId :: UnitId -> DefUnitId-unsafeMkDefUnitId = DefUnitId
− src/Distribution/Types/UnqualComponentName.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Distribution.Types.UnqualComponentName-  ( UnqualComponentName, unUnqualComponentName, unUnqualComponentNameST, mkUnqualComponentName-  , packageNameToUnqualComponentName, unqualComponentNameToPackageName-  ) where--import Distribution.Compat.Prelude-import Distribution.Utils.ShortText-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty-import Distribution.Types.PackageName---- | An unqualified component name, for any kind of component.------ This is distinguished from a 'ComponentName' and 'ComponentId'. The former--- also states which of a library, executable, etc the name refers too. The--- later uniquely identifiers a component and its closure.------ @since 2.0.0.2-newtype UnqualComponentName = UnqualComponentName ShortText-  deriving (Generic, Read, Show, Eq, Ord, Typeable, Data,-            Semigroup, Monoid) -- TODO: bad enabler of bad monoids---- | Convert 'UnqualComponentName' to 'String'------ @since 2.0.0.2-unUnqualComponentName :: UnqualComponentName -> String-unUnqualComponentName (UnqualComponentName s) = fromShortText s---- | @since 3.4.0.0-unUnqualComponentNameST :: UnqualComponentName -> ShortText-unUnqualComponentNameST (UnqualComponentName s) = s---- | Construct a 'UnqualComponentName' from a 'String'------ 'mkUnqualComponentName' is the inverse to 'unUnqualComponentName'------ Note: No validations are performed to ensure that the resulting--- 'UnqualComponentName' is valid------ @since 2.0.0.2-mkUnqualComponentName :: String -> UnqualComponentName-mkUnqualComponentName = UnqualComponentName . toShortText---- | 'mkUnqualComponentName'------ @since 2.0.0.2-instance IsString UnqualComponentName where-  fromString = mkUnqualComponentName--instance Binary UnqualComponentName-instance Structured UnqualComponentName--instance Pretty UnqualComponentName where-  pretty = showToken . unUnqualComponentName--instance Parsec UnqualComponentName where-  parsec = mkUnqualComponentName <$> parsecUnqualComponentName--instance NFData UnqualComponentName where-  rnf (UnqualComponentName pkg) = rnf pkg---- TODO avoid String round trip with these PackageName <->--- UnqualComponentName converters.---- | Converts a package name to an unqualified component name------ Useful in legacy situations where a package name may refer to an internal--- component, if one is defined with that name.------ 2018-12-21: These "legacy" situations are not legacy.--- We can @build-depends@ on the internal library. However--- Now dependency contains @Set LibraryName@, and we should use that.------ @since 2.0.0.2-packageNameToUnqualComponentName :: PackageName -> UnqualComponentName-packageNameToUnqualComponentName = UnqualComponentName . unPackageNameST---- | Converts an unqualified component name to a package name------ `packageNameToUnqualComponentName` is the inverse of--- `unqualComponentNameToPackageName`.------ Useful in legacy situations where a package name may refer to an internal--- component, if one is defined with that name.------ @since 2.0.0.2-unqualComponentNameToPackageName :: UnqualComponentName -> PackageName-unqualComponentNameToPackageName = mkPackageNameST . unUnqualComponentNameST
− src/Distribution/Types/Version.hs 
@@ -1,242 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.Types.Version (-    -- * Package versions-    Version,-    mkVersion,-    mkVersion',-    versionNumbers,-    nullVersion,-    alterVersion,-    version0,--    -- * Internal-    validVersion,-    versionDigitParser,-    ) where--import Data.Bits                   (shiftL, shiftR, (.&.), (.|.))-import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Parsec-import Distribution.Pretty--import qualified Data.Version                    as Base-import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp-import qualified Text.Read                       as Read---- | A 'Version' represents the version of a software entity.------ Instances of 'Eq' and 'Ord' are provided, which gives exact--- equality and lexicographic ordering of the version number--- components (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2, etc.).------ This type is opaque and distinct from the 'Base.Version' type in--- "Data.Version" since @Cabal-2.0@. The difference extends to the--- 'Binary' instance using a different (and more compact) encoding.------ @since 2.0.0.2-data Version = PV0 {-# UNPACK #-} !Word64-             | PV1 !Int [Int]-             -- NOTE: If a version fits into the packed Word64-             -- representation (i.e. at most four version components-             -- which all fall into the [0..0xfffe] range), then PV0-             -- MUST be used. This is essential for the 'Eq' instance-             -- to work.-             deriving (Data,Eq,Generic,Typeable)--instance Ord Version where-    compare (PV0 x)    (PV0 y)    = compare x y-    compare (PV1 x xs) (PV1 y ys) = case compare x y of-        EQ -> compare xs ys-        c  -> c-    compare (PV0 w)    (PV1 y ys) = case compare x y of-        EQ -> compare [x2,x3,x4] ys-        c  -> c-      where-        x  = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1-        x2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1-        x3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1-        x4 = fromIntegral               (w .&. 0xffff) - 1-    compare (PV1 x xs) (PV0 w)    = case compare x y of-        EQ -> compare xs [y2,y3,y4]-        c  -> c-      where-        y  = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1-        y2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1-        y3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1-        y4 = fromIntegral               (w .&. 0xffff) - 1--instance Show Version where-    showsPrec d v = showParen (d > 10)-        $ showString "mkVersion "-        . showsPrec 11 (versionNumbers v)--instance Read Version where-    readPrec = Read.parens $ do-        Read.Ident "mkVersion" <- Read.lexP-        v <- Read.step Read.readPrec-        return (mkVersion v)--instance Binary Version-instance Structured Version--instance NFData Version where-    rnf (PV0 _) = ()-    rnf (PV1 _ ns) = rnf ns--instance Pretty Version where-  pretty ver-    = Disp.hcat (Disp.punctuate (Disp.char '.')-                                (map Disp.int $ versionNumbers ver))--instance Parsec Version where-    parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags-      where-        tags = do-            ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum)-            case ts of-                []      -> pure ()-                (_ : _) -> parsecWarning PWTVersionTag "version with tags"---- | An integral without leading zeroes.------ @since 3.0-versionDigitParser :: CabalParsing m => m Int-versionDigitParser = (some d >>= toNumber) P.<?> "version digit (integral without leading zeroes)"-  where-    toNumber :: CabalParsing m => [Int] -> m Int-    toNumber [0]   = return 0-    toNumber (0:_) = P.unexpected "Version digit with leading zero"-    toNumber xs-        -- 10^9 = 1000000000-        -- 2^30 = 1073741824-        ---        -- GHC Int is at least 32 bits, so 2^31-1 is the 'maxBound'.-        | length xs > 9 = P.unexpected "At most 9 numbers are allowed per version number part"-        | otherwise     = return $ foldl' (\a b -> a * 10 + b) 0 xs--    d :: P.CharParsing m => m Int-    d = f <$> P.satisfyRange '0' '9'-    f c = ord c - ord '0'---- | Construct 'Version' from list of version number components.------ For instance, @mkVersion [3,2,1]@ constructs a 'Version'--- representing the version @3.2.1@.------ All version components must be non-negative. @mkVersion []@--- currently represents the special /null/ version; see also 'nullVersion'.------ @since 2.0.0.2-mkVersion :: [Int] -> Version--- TODO: add validity check; disallow 'mkVersion []' (we have--- 'nullVersion' for that)-mkVersion []                    = nullVersion-mkVersion (v1:[])-  | inWord16VerRep1 v1          = PV0 (mkWord64VerRep1 v1)-  | otherwise                   = PV1 v1 []-  where-    inWord16VerRep1 x1 = inWord16 (x1 .|. (x1+1))-    mkWord64VerRep1 y1 = mkWord64VerRep (y1+1) 0 0 0--mkVersion (v1:vs@(v2:[]))-  | inWord16VerRep2 v1 v2       = PV0 (mkWord64VerRep2 v1 v2)-  | otherwise                   = PV1 v1 vs-  where-    inWord16VerRep2 x1 x2 = inWord16 (x1 .|. (x1+1)-                                  .|. x2 .|. (x2+1))-    mkWord64VerRep2 y1 y2 = mkWord64VerRep (y1+1) (y2+1) 0 0--mkVersion (v1:vs@(v2:v3:[]))-  | inWord16VerRep3 v1 v2 v3    = PV0 (mkWord64VerRep3 v1 v2 v3)-  | otherwise                   = PV1 v1 vs-  where-    inWord16VerRep3 x1 x2 x3 = inWord16 (x1 .|. (x1+1)-                                     .|. x2 .|. (x2+1)-                                     .|. x3 .|. (x3+1))-    mkWord64VerRep3 y1 y2 y3 = mkWord64VerRep (y1+1) (y2+1) (y3+1) 0--mkVersion (v1:vs@(v2:v3:v4:[]))-  | inWord16VerRep4 v1 v2 v3 v4 = PV0 (mkWord64VerRep4 v1 v2 v3 v4)-  | otherwise                   = PV1 v1 vs-  where-    inWord16VerRep4 x1 x2 x3 x4 = inWord16 (x1 .|. (x1+1)-                                        .|. x2 .|. (x2+1)-                                        .|. x3 .|. (x3+1)-                                        .|. x4 .|. (x4+1))-    mkWord64VerRep4 y1 y2 y3 y4 = mkWord64VerRep (y1+1) (y2+1) (y3+1) (y4+1)--mkVersion (v1:vs)               = PV1 v1 vs---- | Version 0. A lower bound of 'Version'.------ @since 2.2-version0 :: Version-version0 = mkVersion [0]--{-# INLINE mkWord64VerRep #-}-mkWord64VerRep :: Int -> Int -> Int -> Int -> Word64-mkWord64VerRep v1 v2 v3 v4 =-      (fromIntegral v1 `shiftL` 48)-  .|. (fromIntegral v2 `shiftL` 32)-  .|. (fromIntegral v3 `shiftL` 16)-  .|.  fromIntegral v4--{-# INLINE inWord16 #-}-inWord16 :: Int -> Bool-inWord16 x = (fromIntegral x :: Word) <= 0xffff---- | Variant of 'mkVersion' which converts a "Data.Version"--- 'Base.Version' into Cabal's 'Version' type.------ @since 2.0.0.2-mkVersion' :: Base.Version -> Version-mkVersion' = mkVersion . Base.versionBranch---- | Unpack 'Version' into list of version number components.------ This is the inverse to 'mkVersion', so the following holds:------ > (versionNumbers . mkVersion) vs == vs------ @since 2.0.0.2-versionNumbers :: Version -> [Int]-versionNumbers (PV1 n ns) = n:ns-versionNumbers (PV0 w)-  | v1 < 0    = []-  | v2 < 0    = [v1]-  | v3 < 0    = [v1,v2]-  | v4 < 0    = [v1,v2,v3]-  | otherwise = [v1,v2,v3,v4]-  where-    v1 = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1-    v2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1-    v3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1-    v4 = fromIntegral (w .&. 0xffff) - 1----- | Constant representing the special /null/ 'Version'------ The 'nullVersion' compares (via 'Ord') as less than every proper--- 'Version' value.------ @since 2.0.0.2-nullVersion :: Version--- TODO: at some point, 'mkVersion' may disallow creating /null/--- 'Version's-nullVersion = PV0 0---- | Apply function to list of version number components------ > alterVersion f == mkVersion . f . versionNumbers------ @since 2.0.0.2-alterVersion :: ([Int] -> [Int]) -> Version -> Version-alterVersion f = mkVersion . f . versionNumbers---- internal helper-validVersion :: Version -> Bool-validVersion v = v /= nullVersion && all (>=0) (versionNumbers v)
− src/Distribution/Types/VersionInterval.hs 
@@ -1,345 +0,0 @@-{-# LANGUAGE BangPatterns       #-}-{-# LANGUAGE DeriveDataTypeable #-}--- | In @Cabal-3.6@ this module have been rewritten.-------module Distribution.Types.VersionInterval (-    -- * Version intervals-    VersionIntervals,-    unVersionIntervals,--    -- * Conversions-    toVersionIntervals,-    fromVersionIntervals,--    -- ** Normalisation-    normaliseVersionRange2,--    -- * Relaxation-    relaxLastInterval,-    relaxHeadInterval,--    -- * Version intervals view-    asVersionIntervals,-    VersionInterval (..),-    LowerBound(..),-    UpperBound(..),-    Bound(..),--    -- * Invariants-    invariantVersionIntervals,-    ) where--import Control.Applicative         (liftA2)-import Control.Exception           (assert)-import Distribution.Compat.Prelude-import Prelude ()--import Distribution.Types.Version-import Distribution.Types.VersionRange.Internal---- To test this module, and to run version range normalisation benchmarks:------ cabal run Cabal:unit-tests -- -p Distribution.Version--- cabal run cabal-benchmarks -- -o bench.html normaliseVersionRange------------------------------------------------------------------------------------ Data------------------------------------------------------------------------------------ | A complementary representation of a 'VersionRange'. Instead of a boolean--- version predicate it uses an increasing sequence of non-overlapping,--- non-empty intervals.------ The key point is that this representation gives a canonical representation--- for the semantics of 'VersionRange's. This makes it easier to check things--- like whether a version range is empty, covers all versions, or requires a--- certain minimum or maximum version. It also makes it easy to check equality--- or containment. It also makes it easier to identify \'simple\' version--- predicates for translation into foreign packaging systems that do not--- support complex version range expressions.----newtype VersionIntervals = VersionIntervals [VersionInterval]-  deriving (Eq, Show, Typeable)---- | Inspect the list of version intervals.----unVersionIntervals :: VersionIntervals -> [VersionInterval]-unVersionIntervals (VersionIntervals is) = is--data VersionInterval = VersionInterval !LowerBound !UpperBound    deriving (Eq, Show)-data LowerBound      = LowerBound !Version !Bound                 deriving (Eq, Show)-data UpperBound      = NoUpperBound | UpperBound !Version !Bound  deriving (Eq, Show)-data Bound           = ExclusiveBound | InclusiveBound            deriving (Eq, Show)--zeroLowerBound :: LowerBound-zeroLowerBound = LowerBound version0 InclusiveBound--isVersion0 :: Version -> Bool-isVersion0 = (==) version0------------------------------------------------------------------------------------ Stage1----------------------------------------------------------------------------------stage1 :: VersionRange -> [VersionInterval]-stage1 = cataVersionRange alg where-    -- version range leafs transform into singleton intervals-    alg (ThisVersionF v)                = [VersionInterval (LowerBound v InclusiveBound) (UpperBound v InclusiveBound)]-    alg (LaterVersionF v)               = [VersionInterval (LowerBound v ExclusiveBound) NoUpperBound]-    alg (OrLaterVersionF v)             = [VersionInterval (LowerBound v InclusiveBound) NoUpperBound]-    alg (EarlierVersionF v)-        | isVersion0 v                  = []-        | otherwise                     = [VersionInterval zeroLowerBound                (UpperBound v ExclusiveBound)]-    alg (OrEarlierVersionF v)           = [VersionInterval zeroLowerBound                (UpperBound v InclusiveBound)]--    -- ^>= version-range's upper bound should be MajorBound-    alg (MajorBoundVersionF v)          = [VersionInterval (LowerBound v InclusiveBound) (UpperBound (majorUpperBound v) ExclusiveBound)]--    -- union: just merge the version intervals-    alg (UnionVersionRangesF v1 v2)     = v1 ++ v2--    -- intersection: pairwise intersect. Strip empty intervals. Sort to restore the invariant.-    alg (IntersectVersionRangesF v1 v2) = mapMaybe nonEmptyInterval $ liftA2 intersectInterval (stage2and3 v1) (stage2and3 v2)---- | Creck that interval is non-empty-nonEmptyInterval :: VersionInterval -> Maybe VersionInterval-nonEmptyInterval i | nonEmptyVI i = Just i-nonEmptyInterval _                = Nothing------------------------------------------------------------------------------------ Stage2----------------------------------------------------------------------------------stage2 :: [VersionInterval] -> [VersionInterval]-stage2 = sortBy lowerboundCmp--lowerboundCmp :: VersionInterval -> VersionInterval -> Ordering-lowerboundCmp (VersionInterval (LowerBound v vb) _) (VersionInterval (LowerBound u ub) _) =-    compare v u `mappend` compareBound vb ub-  where-    compareBound :: Bound -> Bound -> Ordering-    compareBound InclusiveBound InclusiveBound = EQ-    compareBound InclusiveBound ExclusiveBound = LT-    compareBound ExclusiveBound InclusiveBound = GT-    compareBound ExclusiveBound ExclusiveBound = EQ------------------------------------------------------------------------------------ Postprocess------------------------------------------------------------------------------------ | Post-processing takes a list of ordered version intervals,--- but possibly overlapping, and creates 'VersionIntervals'.----postprocess :: [VersionInterval] -> VersionIntervals-postprocess = checkInvariant . VersionIntervals . stage2and3--stage2and3 :: [VersionInterval] -> [VersionInterval]-stage2and3 = stage3 . stage2--stage3 :: [VersionInterval] -> [VersionInterval]-stage3 []                                     = []-stage3 (VersionInterval lb ub : rest)         = stage3go lb ub rest--stage3go :: LowerBound -> UpperBound -> [VersionInterval] -> [VersionInterval]-stage3go !lb NoUpperBound _                                 = [VersionInterval lb NoUpperBound]-stage3go !lb !ub          []                                = [VersionInterval lb ub]-stage3go !lb !ub          (VersionInterval lb' ub' : rest')-    | doesNotTouch ub lb'                                   = VersionInterval lb ub : stage3go lb' ub' rest'-    | otherwise                                             = stage3go lb (unionUpper ub ub') rest'------------------------------------------------------------------------------------ Intersections----------------------------------------------------------------------------------intersectInterval :: VersionInterval -> VersionInterval -> VersionInterval-intersectInterval (VersionInterval lv uv) (VersionInterval lu uu) =-    VersionInterval (intersectLower lv lu) (intersectUpper uv uu)--intersectLower :: LowerBound -> LowerBound -> LowerBound-intersectLower (LowerBound v vb) (LowerBound u ub) = case compare v u of-    EQ -> LowerBound v (intersectBound vb ub)-    LT -> LowerBound u ub-    GT -> LowerBound v vb--intersectUpper :: UpperBound -> UpperBound -> UpperBound-intersectUpper NoUpperBound      b                 = b-intersectUpper b                 NoUpperBound      = b-intersectUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of-    EQ -> UpperBound v (intersectBound vb ub)-    LT -> UpperBound v vb-    GT -> UpperBound u ub--intersectBound :: Bound -> Bound -> Bound-intersectBound InclusiveBound InclusiveBound = InclusiveBound-intersectBound _              _              = ExclusiveBound------------------------------------------------------------------------------------ Unions----------------------------------------------------------------------------------unionUpper :: UpperBound -> UpperBound -> UpperBound-unionUpper NoUpperBound      _                 = NoUpperBound-unionUpper _                 NoUpperBound      = NoUpperBound-unionUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of-    EQ -> UpperBound v (unionBound vb ub)-    LT -> UpperBound u ub-    GT -> UpperBound v vb--unionBound :: Bound -> Bound -> Bound-unionBound ExclusiveBound ExclusiveBound = ExclusiveBound-unionBound _              _              = InclusiveBound------------------------------------------------------------------------------------ VersionRange------------------------------------------------------------------------------------ | View a 'VersionRange' as a union of intervals.------ This provides a canonical view of the semantics of a 'VersionRange' as--- opposed to the syntax of the expression used to define it. For the syntactic--- view use 'foldVersionRange'.------ Each interval is non-empty. The sequence is in increasing order and no--- intervals overlap or touch. Therefore only the first and last can be--- unbounded. The sequence can be empty if the range is empty--- (e.g. a range expression like @< 1 && > 2@).------ Other checks are trivial to implement using this view. For example:------ > isNoVersion vr | [] <- asVersionIntervals vr = True--- >                | otherwise                   = False------ > isSpecificVersion vr--- >    | [(LowerBound v  InclusiveBound--- >       ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr--- >    , v == v'   = Just v--- >    | otherwise = Nothing----asVersionIntervals :: VersionRange -> [VersionInterval]-asVersionIntervals = unVersionIntervals . toVersionIntervals------------------------------------------------------------------------------------ Helpers------------------------------------------------------------------------------------ | Check an upper bound does not intersect, or even touch a lower bound:------ @---   ---|      or  ---)     but not  ---]     or  ---)     or  ---]---       |---         (---              (---         [---         [------ @----doesNotTouch :: UpperBound -> LowerBound -> Bool-doesNotTouch NoUpperBound      _                 = False-doesNotTouch (UpperBound u ub) (LowerBound l lb) =-    (u < l) || (u == l && ub == ExclusiveBound && lb == ExclusiveBound)------------------------------------------------------------------------------------ Invariants------------------------------------------------------------------------------------ | 'VersionIntervals' invariant:------ * all intervals are valid (lower bound is less then upper bound, i.e. non-empty)--- * intervals doesn't touch each other (distinct)----invariantVersionIntervals :: VersionIntervals -> Bool-invariantVersionIntervals (VersionIntervals intervals) =-    all validInterval intervals &&-    all doesNotTouch' adjacentIntervals-  where-    doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool-    doesNotTouch' (VersionInterval _ u, VersionInterval l' _) = doesNotTouch u l'--    adjacentIntervals :: [(VersionInterval, VersionInterval)]-    adjacentIntervals = case intervals of-      []     -> []-      (_:tl) -> zip intervals tl--checkInvariant :: VersionIntervals -> VersionIntervals-checkInvariant is = assert (invariantVersionIntervals is) is-{-# INLINE checkInvariant #-}--validInterval :: VersionInterval -> Bool-validInterval i@(VersionInterval l u) = validLower l && validUpper u && nonEmptyVI i-  where-    validLower (LowerBound v _) = validVersion v-    validUpper NoUpperBound      = True-    validUpper (UpperBound v _)  = validVersion v---- Check an interval is non-empty----nonEmptyVI :: VersionInterval -> Bool-nonEmptyVI (VersionInterval _                 NoUpperBound)      = True-nonEmptyVI (VersionInterval (LowerBound l lb) (UpperBound u ub)) =-  (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound)------------------------------------------------------------------------------------ Conversions------------------------------------------------------------------------------------ | Convert a 'VersionRange' to a sequence of version intervals.----toVersionIntervals :: VersionRange -> VersionIntervals-toVersionIntervals = postprocess . stage1---- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression--- representing the version intervals.----fromVersionIntervals :: VersionIntervals -> VersionRange-fromVersionIntervals (VersionIntervals [])     = noVersion-fromVersionIntervals (VersionIntervals (x:xs)) = foldr1 unionVersionRanges (fmap intervalToVersionRange (x:|xs))--intervalToVersionRange :: VersionInterval -> VersionRange-intervalToVersionRange (VersionInterval (LowerBound v vb) upper') = case upper' of-    NoUpperBound-        -> lowerBound--    UpperBound u ub-        | vb == InclusiveBound-        , ub == InclusiveBound-        , v == u-        -> thisVersion v--    UpperBound u ub -> withLowerBound (makeUpperBound u ub)-  where-    lowerBound :: VersionRange-    lowerBound = case vb of-        InclusiveBound -> orLaterVersion v-        ExclusiveBound -> laterVersion v--    withLowerBound :: VersionRange -> VersionRange-    withLowerBound vr-        | isVersion0 v, vb == InclusiveBound = vr-        | otherwise                          = intersectVersionRanges lowerBound vr--    makeUpperBound :: Version -> Bound -> VersionRange-    makeUpperBound u InclusiveBound = orEarlierVersion u-    makeUpperBound u ExclusiveBound = earlierVersion u------------------------------------------------------------------------------------ Normalisation------------------------------------------------------------------------------------ | Since @Cabal-3.6@ this function.. TODO----normaliseVersionRange2 :: VersionRange -> VersionRange-normaliseVersionRange2 = fromVersionIntervals . toVersionIntervals------------------------------------------------------------------------------------ Relaxation----------------------------------------------------------------------------------relaxLastInterval :: VersionIntervals -> VersionIntervals-relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs)-  where-    relaxLastInterval' []                    = []-    relaxLastInterval' [VersionInterval l _] = [VersionInterval l NoUpperBound]-    relaxLastInterval' (i:is)                = i : relaxLastInterval' is--relaxHeadInterval :: VersionIntervals -> VersionIntervals-relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs)-  where-    relaxHeadInterval' []                         = []-    relaxHeadInterval' (VersionInterval _ u : is) = VersionInterval zeroLowerBound u : is
− src/Distribution/Types/VersionInterval/Legacy.hs 
@@ -1,368 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--- | This is old version of "Distribution.Types.VersionInterval" module.------ It will be removed in @Cabal-3.8@.----module Distribution.Types.VersionInterval.Legacy {-# DEPRECATED "Use Distribution.Types.VersionInterval instead" #-} (-    -- * Version intervals-    VersionIntervals,-    toVersionIntervals,-    fromVersionIntervals,-    withinIntervals,-    versionIntervals,-    mkVersionIntervals,-    unionVersionIntervals,-    intersectVersionIntervals,-    invertVersionIntervals,-    relaxLastInterval,-    relaxHeadInterval,--    -- * Version intervals view-    asVersionIntervals,-    VersionInterval,-    LowerBound(..),-    UpperBound(..),-    Bound(..),-    ) where--import Prelude ()-import Distribution.Compat.Prelude-import Control.Exception (assert)--import Distribution.Types.Version-import Distribution.Types.VersionRange.Internal---- NonEmpty-import qualified Prelude (foldr1)------------------------------------------------------------------------------------ VersionRange------------------------------------------------------------------------------------ | View a 'VersionRange' as a union of intervals.------ This provides a canonical view of the semantics of a 'VersionRange' as--- opposed to the syntax of the expression used to define it. For the syntactic--- view use 'foldVersionRange'.------ Each interval is non-empty. The sequence is in increasing order and no--- intervals overlap or touch. Therefore only the first and last can be--- unbounded. The sequence can be empty if the range is empty--- (e.g. a range expression like @< 1 && > 2@).------ Other checks are trivial to implement using this view. For example:------ > isNoVersion vr | [] <- asVersionIntervals vr = True--- >                | otherwise                   = False------ > isSpecificVersion vr--- >    | [(LowerBound v  InclusiveBound--- >       ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr--- >    , v == v'   = Just v--- >    | otherwise = Nothing----asVersionIntervals :: VersionRange -> [VersionInterval]-asVersionIntervals = versionIntervals . toVersionIntervals------------------------------------------------------------------------------------- VersionInterval------------------------------------------------------------------------------------ | A complementary representation of a 'VersionRange'. Instead of a boolean--- version predicate it uses an increasing sequence of non-overlapping,--- non-empty intervals.------ The key point is that this representation gives a canonical representation--- for the semantics of 'VersionRange's. This makes it easier to check things--- like whether a version range is empty, covers all versions, or requires a--- certain minimum or maximum version. It also makes it easy to check equality--- or containment. It also makes it easier to identify \'simple\' version--- predicates for translation into foreign packaging systems that do not--- support complex version range expressions.----newtype VersionIntervals = VersionIntervals [VersionInterval]-  deriving (Eq, Show, Typeable)---- | Inspect the list of version intervals.----versionIntervals :: VersionIntervals -> [VersionInterval]-versionIntervals (VersionIntervals is) = is--type VersionInterval = (LowerBound, UpperBound)-data LowerBound =                LowerBound Version !Bound deriving (Eq, Show)-data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show)-data Bound      = ExclusiveBound | InclusiveBound          deriving (Eq, Show)--minLowerBound :: LowerBound-minLowerBound = LowerBound (mkVersion [0]) InclusiveBound--isVersion0 :: Version -> Bool-isVersion0 = (==) version0--instance Ord LowerBound where-  LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of-    LT -> True-    EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound)-    GT -> False--instance Ord UpperBound where-  _            <= NoUpperBound   = True-  NoUpperBound <= UpperBound _ _ = False-  UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of-    LT -> True-    EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound)-    GT -> False--invariant :: VersionIntervals -> Bool-invariant (VersionIntervals intervals) = all validInterval intervals-                                      && all doesNotTouch' adjacentIntervals-  where-    doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool-    doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l'--    adjacentIntervals :: [(VersionInterval, VersionInterval)]-    adjacentIntervals = case intervals of-      []     -> []-      (_:tl) -> zip intervals tl--checkInvariant :: VersionIntervals -> VersionIntervals-checkInvariant is = assert (invariant is) is---- | Directly construct a 'VersionIntervals' from a list of intervals.------ In @Cabal-2.2@ the 'Maybe' is dropped from the result type.----mkVersionIntervals :: [VersionInterval] -> VersionIntervals-mkVersionIntervals intervals-    | invariant (VersionIntervals intervals) = VersionIntervals intervals-    | otherwise-        = checkInvariant-        . foldl' (flip insertInterval) (VersionIntervals [])-        . filter validInterval-        $ intervals--insertInterval :: VersionInterval -> VersionIntervals -> VersionIntervals-insertInterval i is = unionVersionIntervals (VersionIntervals [i]) is--validInterval :: (LowerBound, UpperBound) -> Bool-validInterval i@(l, u) = validLower l && validUpper u && nonEmptyVI i-  where-    validLower (LowerBound v _) = validVersion v-    validUpper NoUpperBound     = True-    validUpper (UpperBound v _) = validVersion v---- Check an interval is non-empty----nonEmptyVI :: VersionInterval -> Bool-nonEmptyVI (_,               NoUpperBound   ) = True-nonEmptyVI (LowerBound l lb, UpperBound u ub) =-  (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound)---- Check an upper bound does not intersect, or even touch a lower bound:------   ---|      or  ---)     but not  ---]     or  ---)     or  ---]---       |---         (---              (---         [---         [-------doesNotTouch :: UpperBound -> LowerBound -> Bool-doesNotTouch NoUpperBound _ = False-doesNotTouch (UpperBound u ub) (LowerBound l lb) =-      u <  l-  || (u == l && ub == ExclusiveBound && lb == ExclusiveBound)---- | Check an upper bound does not intersect a lower bound:------   ---|      or  ---)     or  ---]     or  ---)     but not  ---]---       |---         (---         (---         [---              [-------doesNotIntersect :: UpperBound -> LowerBound -> Bool-doesNotIntersect NoUpperBound _ = False-doesNotIntersect (UpperBound u ub) (LowerBound l lb) =-      u <  l-  || (u == l && not (ub == InclusiveBound && lb == InclusiveBound))---- | Test if a version falls within the version intervals.------ It exists mostly for completeness and testing. It satisfies the following--- properties:------ > withinIntervals v (toVersionIntervals vr) = withinRange v vr--- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs)----withinIntervals :: Version -> VersionIntervals -> Bool-withinIntervals v (VersionIntervals intervals) = any withinInterval intervals-  where-    withinInterval (lowerBound, upperBound)    = withinLower lowerBound-                                              && withinUpper upperBound-    withinLower (LowerBound v' ExclusiveBound) = v' <  v-    withinLower (LowerBound v' InclusiveBound) = v' <= v--    withinUpper NoUpperBound                   = True-    withinUpper (UpperBound v' ExclusiveBound) = v' >  v-    withinUpper (UpperBound v' InclusiveBound) = v' >= v---- | Convert a 'VersionRange' to a sequence of version intervals.----toVersionIntervals :: VersionRange -> VersionIntervals-toVersionIntervals = cataVersionRange alg where-    alg (ThisVersionF v)                = chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)-    alg (LaterVersionF v)               = chkIvl (LowerBound v ExclusiveBound, NoUpperBound)-    alg (OrLaterVersionF v)             = chkIvl (LowerBound v InclusiveBound, NoUpperBound)-    alg (EarlierVersionF v)-        | isVersion0 v                  = VersionIntervals []-        | otherwise                     = chkIvl (minLowerBound,               UpperBound v ExclusiveBound)-    alg (OrEarlierVersionF v)           = chkIvl (minLowerBound,               UpperBound v InclusiveBound)-    alg (MajorBoundVersionF v)          = chkIvl (LowerBound v InclusiveBound, UpperBound (majorUpperBound v) ExclusiveBound)-    alg (UnionVersionRangesF v1 v2)     = unionVersionIntervals v1 v2-    alg (IntersectVersionRangesF v1 v2) = intersectVersionIntervals v1 v2--    chkIvl interval = checkInvariant (VersionIntervals [interval])---- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression--- representing the version intervals.----fromVersionIntervals :: VersionIntervals -> VersionRange-fromVersionIntervals (VersionIntervals []) = noVersion-fromVersionIntervals (VersionIntervals intervals) =-    Prelude.foldr1 unionVersionRanges [ interval l u | (l, u) <- intervals ]--  where-    interval (LowerBound v  InclusiveBound)-             (UpperBound v' InclusiveBound) | v == v'-                 = thisVersion v-    interval l u = lowerBound l `intersectVersionRanges'` upperBound u--    lowerBound (LowerBound v InclusiveBound)-                              | isVersion0 v = Nothing-                              | otherwise    = Just (orLaterVersion v)-    lowerBound (LowerBound v ExclusiveBound) = Just (laterVersion v)--    upperBound NoUpperBound                  = Nothing-    upperBound (UpperBound v InclusiveBound) = Just (orEarlierVersion v)-    upperBound (UpperBound v ExclusiveBound) = Just (earlierVersion v)--    intersectVersionRanges' Nothing Nothing      = anyVersion-    intersectVersionRanges' (Just vr) Nothing    = vr-    intersectVersionRanges' Nothing (Just vr)    = vr-    intersectVersionRanges' (Just vr) (Just vr') = intersectVersionRanges vr vr'--unionVersionIntervals :: VersionIntervals -> VersionIntervals-                      -> VersionIntervals-unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) =-  checkInvariant (VersionIntervals (union is0 is'0))-  where-    union is []  = is-    union [] is' = is'-    union (i:is) (i':is') = case unionInterval i i' of-      Left  Nothing    -> i  : union      is  (i' :is')-      Left  (Just i'') ->      union      is  (i'':is')-      Right Nothing    -> i' : union (i  :is)      is'-      Right (Just i'') ->      union (i'':is)      is'--unionInterval :: VersionInterval -> VersionInterval-              -> Either (Maybe VersionInterval) (Maybe VersionInterval)-unionInterval (lower , upper ) (lower', upper')--  -- Non-intersecting intervals with the left interval ending first-  | upper `doesNotTouch` lower' = Left Nothing--  -- Non-intersecting intervals with the right interval first-  | upper' `doesNotTouch` lower = Right Nothing--  -- Complete or partial overlap, with the left interval ending first-  | upper <= upper' = lowerBound `seq`-                      Left (Just (lowerBound, upper'))--  -- Complete or partial overlap, with the left interval ending first-  | otherwise = lowerBound `seq`-                Right (Just (lowerBound, upper))-  where-    lowerBound = min lower lower'--intersectVersionIntervals :: VersionIntervals -> VersionIntervals-                          -> VersionIntervals-intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) =-  checkInvariant (VersionIntervals (intersect is0 is'0))-  where-    intersect _  [] = []-    intersect [] _  = []-    intersect (i:is) (i':is') = case intersectInterval i i' of-      Left  Nothing    ->       intersect is (i':is')-      Left  (Just i'') -> i'' : intersect is (i':is')-      Right Nothing    ->       intersect (i:is) is'-      Right (Just i'') -> i'' : intersect (i:is) is'--intersectInterval :: VersionInterval -> VersionInterval-                  -> Either (Maybe VersionInterval) (Maybe VersionInterval)-intersectInterval (lower , upper ) (lower', upper')--  -- Non-intersecting intervals with the left interval ending first-  | upper `doesNotIntersect` lower' = Left Nothing--  -- Non-intersecting intervals with the right interval first-  | upper' `doesNotIntersect` lower = Right Nothing--  -- Complete or partial overlap, with the left interval ending first-  | upper <= upper' = lowerBound `seq`-                      Left (Just (lowerBound, upper))--  -- Complete or partial overlap, with the right interval ending first-  | otherwise = lowerBound `seq`-                Right (Just (lowerBound, upper'))-  where-    lowerBound = max lower lower'--invertVersionIntervals :: VersionIntervals-                       -> VersionIntervals-invertVersionIntervals (VersionIntervals xs) =-    case xs of-      -- Empty interval set-      [] -> VersionIntervals [(noLowerBound, NoUpperBound)]-      -- Interval with no lower bound-      ((lb, ub) : more) | lb == noLowerBound ->-        VersionIntervals $ invertVersionIntervals' ub more-      -- Interval with a lower bound-      ((lb, ub) : more) ->-          VersionIntervals $ (noLowerBound, invertLowerBound lb)-          : invertVersionIntervals' ub more-    where-      -- Invert subsequent version intervals given the upper bound of-      -- the intervals already inverted.-      invertVersionIntervals' :: UpperBound-                              -> [(LowerBound, UpperBound)]-                              -> [(LowerBound, UpperBound)]-      invertVersionIntervals' NoUpperBound [] = []-      invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)]-      invertVersionIntervals' ub0 [(lb, NoUpperBound)] =-          [(invertUpperBound ub0, invertLowerBound lb)]-      invertVersionIntervals' ub0 ((lb, ub1) : more) =-          (invertUpperBound ub0, invertLowerBound lb)-            : invertVersionIntervals' ub1 more--      invertLowerBound :: LowerBound -> UpperBound-      invertLowerBound (LowerBound v b) = UpperBound v (invertBound b)--      invertUpperBound :: UpperBound -> LowerBound-      invertUpperBound (UpperBound v b) = LowerBound v (invertBound b)-      invertUpperBound NoUpperBound = error "NoUpperBound: unexpected"--      invertBound :: Bound -> Bound-      invertBound ExclusiveBound = InclusiveBound-      invertBound InclusiveBound = ExclusiveBound--      noLowerBound :: LowerBound-      noLowerBound = LowerBound (mkVersion [0]) InclusiveBound---relaxLastInterval :: VersionIntervals -> VersionIntervals-relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs)-  where-    relaxLastInterval' []      = []-    relaxLastInterval' [(l,_)] = [(l, NoUpperBound)]-    relaxLastInterval' (i:is)  = i : relaxLastInterval' is--relaxHeadInterval :: VersionIntervals -> VersionIntervals-relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs)-  where-    relaxHeadInterval' []         = []-    relaxHeadInterval' ((_,u):is) = (minLowerBound,u) : is
− src/Distribution/Types/VersionRange.hs 
@@ -1,180 +0,0 @@-module Distribution.Types.VersionRange (-    -- * Version ranges-    VersionRange,--    -- ** Constructing-    anyVersion, noVersion,-    thisVersion, notThisVersion,-    laterVersion, earlierVersion,-    orLaterVersion, orEarlierVersion,-    unionVersionRanges, intersectVersionRanges,-    withinVersion,-    majorBoundVersion,--    -- ** Inspection-    ---    -- See "Distribution.Version" for more utilities.-    withinRange,-    foldVersionRange,-    normaliseVersionRange,-    stripParensVersionRange,-    hasUpperBound,-    hasLowerBound,--    -- ** Cata & ana-    VersionRangeF (..),-    cataVersionRange,-    anaVersionRange,-    hyloVersionRange,-    projectVersionRange,-    embedVersionRange,--    -- ** Utilities-    isAnyVersion,-    isAnyVersionLight,-    wildcardUpperBound,-    majorUpperBound,-    isWildcardRange,-    versionRangeParser,-    ) where--import Distribution.Compat.Prelude-import Distribution.Types.Version-import Distribution.Types.VersionInterval-import Distribution.Types.VersionRange.Internal-import Prelude ()---- | Fold over the basic syntactic structure of a 'VersionRange'.------ This provides a syntactic view of the expression defining the version range.--- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented--- in terms of the other basic syntax.------ For a semantic view use 'asVersionIntervals'.----foldVersionRange :: a                         -- ^ @\"-any\"@ version-                 -> (Version -> a)            -- ^ @\"== v\"@-                 -> (Version -> a)            -- ^ @\"> v\"@-                 -> (Version -> a)            -- ^ @\"< v\"@-                 -> (a -> a -> a)             -- ^ @\"_ || _\"@ union-                 -> (a -> a -> a)             -- ^ @\"_ && _\"@ intersection-                 -> VersionRange -> a-foldVersionRange _any this later earlier union intersect = fold-  where-    fold = cataVersionRange alg--    alg (ThisVersionF v)                = this v-    alg (LaterVersionF v)               = later v-    alg (OrLaterVersionF v)             = union (this v) (later v)-    alg (EarlierVersionF v)             = earlier v-    alg (OrEarlierVersionF v)           = union (this v) (earlier v)-    alg (MajorBoundVersionF v)          = fold (majorBound v)-    alg (UnionVersionRangesF v1 v2)     = union v1 v2-    alg (IntersectVersionRangesF v1 v2) = intersect v1 v2--    majorBound v = intersectVersionRanges-                     (orLaterVersion v)-                     (earlierVersion (majorUpperBound v))---- | Normalise 'VersionRange'.------ In particular collapse @(== v || > v)@ into @>= v@, and so on.-normaliseVersionRange :: VersionRange -> VersionRange-normaliseVersionRange = hyloVersionRange embed projectVersionRange-  where-    -- == v || > v, > v || == v  ==>  >= v-    embed (UnionVersionRangesF (ThisVersion v) (LaterVersion v')) | v == v' =-        orLaterVersion v-    embed (UnionVersionRangesF (LaterVersion v) (ThisVersion v')) | v == v' =-        orLaterVersion v--    -- == v || < v, < v || == v  ==>  <= v-    embed (UnionVersionRangesF (ThisVersion v) (EarlierVersion v')) | v == v' =-        orEarlierVersion v-    embed (UnionVersionRangesF (EarlierVersion v) (ThisVersion v')) | v == v' =-        orEarlierVersion v--    -- otherwise embed normally-    embed vr = embedVersionRange vr---- |  Remove 'VersionRangeParens' constructors.------ Since version 3.4 this function is 'id', there aren't 'VersionRangeParens' constructor in 'VersionRange' anymore.------ @since 2.2-stripParensVersionRange :: VersionRange -> VersionRange-stripParensVersionRange = id---- | Does this version fall within the given range?------ This is the evaluation function for the 'VersionRange' type.----withinRange :: Version -> VersionRange -> Bool-withinRange v = foldVersionRange-                   True-                   (\v'  -> v == v')-                   (\v'  -> v >  v')-                   (\v'  -> v <  v')-                   (||)-                   (&&)---- | Does this 'VersionRange' place any restriction on the 'Version' or is it--- in fact equivalent to 'AnyVersion'.------ Note this is a semantic check, not simply a syntactic check. So for example--- the following is @True@ (for all @v@).------ > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v)----isAnyVersion :: VersionRange -> Bool-isAnyVersion vr = case asVersionIntervals vr of-    [VersionInterval (LowerBound v InclusiveBound) NoUpperBound] -> v == version0-    _                                                            -> False---- A fast and non-precise version of 'isAnyVersion',--- returns 'True' only for @>= 0@ 'VersionRange's.------ /Do not use/. The "VersionIntervals don't destroy MajorBoundVersion"--- https://github.com/haskell/cabal/pull/6736 pull-request--- will change 'simplifyVersionRange' to properly preserve semantics.--- Then we can use it to normalise 'VersionRange's in tests.----isAnyVersionLight :: VersionRange -> Bool-isAnyVersionLight (OrLaterVersion v) = v == version0-isAnyVersionLight _vr                = False--------------------------------- Wildcard range utilities------isWildcardRange :: Version -> Version -> Bool-isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2)-  where check (n:[]) (m:[]) | n+1 == m = True-        check (n:ns) (m:ms) | n   == m = check ns ms-        check _      _                 = False---- | Does the version range have an upper bound?------ @since 1.24.0.0-hasUpperBound :: VersionRange -> Bool-hasUpperBound = foldVersionRange-                False-                (const True)-                (const False)-                (const True)-                (&&) (||)---- | Does the version range have an explicit lower bound?------ Note: this function only considers the user-specified lower bounds, but not--- the implicit >=0 lower bound.------ @since 1.24.0.0-hasLowerBound :: VersionRange -> Bool-hasLowerBound = foldVersionRange-                False-                (const True)-                (const True)-                (const False)-                (&&) (||)
− src/Distribution/Types/VersionRange/Internal.hs 
@@ -1,526 +0,0 @@-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DeriveFoldable      #-}-{-# LANGUAGE DeriveFunctor       #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE DeriveTraversable   #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | The only purpose of this module is to prevent the export of--- 'VersionRange' constructors from--- 'Distribution.Types.VersionRange'. To avoid creating orphan--- instances, a lot of related code had to be moved here too.--module Distribution.Types.VersionRange.Internal-  ( VersionRange(..)-  , anyVersion, noVersion-  , thisVersion, notThisVersion-  , laterVersion, earlierVersion-  , orLaterVersion, orEarlierVersion-  , unionVersionRanges, intersectVersionRanges-  , withinVersion-  , majorBoundVersion--  , VersionRangeF(..)-  , projectVersionRange-  , embedVersionRange-  , cataVersionRange-  , anaVersionRange-  , hyloVersionRange-  , versionRangeParser--  , majorUpperBound-  , wildcardUpperBound-  ) where--import Distribution.Compat.Prelude-import Distribution.Types.Version-import Prelude ()--import Distribution.CabalSpecVersion-import Distribution.Parsec-import Distribution.Pretty-import Distribution.Utils.Generic    (unsnoc)--import qualified Distribution.Compat.CharParsing as P-import qualified Distribution.Compat.DList       as DList-import qualified Text.PrettyPrint                as Disp--data VersionRange-  = ThisVersion            Version -- = version-  | LaterVersion           Version -- > version  (NB. not >=)-  | OrLaterVersion         Version -- >= version-  | EarlierVersion         Version -- < version-  | OrEarlierVersion       Version -- <= version-  | MajorBoundVersion      Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1)-  | UnionVersionRanges     VersionRange VersionRange-  | IntersectVersionRanges VersionRange VersionRange-  deriving ( Data, Eq, Generic, Read, Show, Typeable )--instance Binary VersionRange-instance Structured VersionRange-instance NFData VersionRange where rnf = genericRnf---- | The version range @-any@. That is, a version range containing all--- versions.------ > withinRange v anyVersion = True----anyVersion :: VersionRange-anyVersion = OrLaterVersion (mkVersion [0])---- | The empty version range, that is a version range containing no versions.------ This can be constructed using any unsatisfiable version range expression,--- for example @< 0@.------ > withinRange v noVersion = False----noVersion :: VersionRange-noVersion = EarlierVersion (mkVersion [0])---- | The version range @== v@------ > withinRange v' (thisVersion v) = v' == v----thisVersion :: Version -> VersionRange-thisVersion = ThisVersion---- | The version range @< v || > v@------ > withinRange v' (notThisVersion v) = v' /= v----notThisVersion :: Version -> VersionRange-notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v)---- | The version range @> v@------ > withinRange v' (laterVersion v) = v' > v----laterVersion :: Version -> VersionRange-laterVersion = LaterVersion---- | The version range @>= v@------ > withinRange v' (orLaterVersion v) = v' >= v----orLaterVersion :: Version -> VersionRange-orLaterVersion = OrLaterVersion---- | The version range @< v@------ > withinRange v' (earlierVersion v) = v' < v----earlierVersion :: Version -> VersionRange-earlierVersion = EarlierVersion---- | The version range @<= v@------ > withinRange v' (orEarlierVersion v) = v' <= v----orEarlierVersion :: Version -> VersionRange-orEarlierVersion = OrEarlierVersion---- | The version range @vr1 || vr2@------ >   withinRange v' (unionVersionRanges vr1 vr2)--- > = withinRange v' vr1 || withinRange v' vr2----unionVersionRanges :: VersionRange -> VersionRange -> VersionRange-unionVersionRanges = UnionVersionRanges---- | The version range @vr1 && vr2@------ >   withinRange v' (intersectVersionRanges vr1 vr2)--- > = withinRange v' vr1 && withinRange v' vr2----intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange-intersectVersionRanges = IntersectVersionRanges---- | The version range @== v.*@.------ For example, for version @1.2@, the version range @== 1.2.*@ is the same as--- @>= 1.2 && < 1.3@------ > withinRange v' (laterVersion v) = v' >= v && v' < upper v--- >   where--- >     upper (Version lower t) = Version (init lower ++ [last lower + 1]) t----withinVersion :: Version -> VersionRange-withinVersion v = intersectVersionRanges-    (orLaterVersion v)-    (earlierVersion (wildcardUpperBound v))---- | The version range @^>= v@.------ For example, for version @1.2.3.4@, the version range @^>= 1.2.3.4@--- is the same as @>= 1.2.3.4 && < 1.3@.------ Note that @^>= 1@ is equivalent to @>= 1 && < 1.1@.------ @since 2.0.0.2-majorBoundVersion :: Version -> VersionRange-majorBoundVersion = MajorBoundVersion----- | F-Algebra of 'VersionRange'. See 'cataVersionRange'.------ @since 2.2-data VersionRangeF a-  = ThisVersionF            Version -- = version-  | LaterVersionF           Version -- > version  (NB. not >=)-  | OrLaterVersionF         Version -- >= version-  | EarlierVersionF         Version -- < version-  | OrEarlierVersionF       Version -- <= version-  | MajorBoundVersionF      Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1)-  | UnionVersionRangesF     a a-  | IntersectVersionRangesF a a-  deriving ( Data, Eq, Generic, Read, Show, Typeable-           , Functor, Foldable, Traversable )---- | @since 2.2-projectVersionRange :: VersionRange -> VersionRangeF VersionRange-projectVersionRange (ThisVersion v)              = ThisVersionF v-projectVersionRange (LaterVersion v)             = LaterVersionF v-projectVersionRange (OrLaterVersion v)           = OrLaterVersionF v-projectVersionRange (EarlierVersion v)           = EarlierVersionF v-projectVersionRange (OrEarlierVersion v)         = OrEarlierVersionF v-projectVersionRange (MajorBoundVersion v)        = MajorBoundVersionF v-projectVersionRange (UnionVersionRanges a b)     = UnionVersionRangesF a b-projectVersionRange (IntersectVersionRanges a b) = IntersectVersionRangesF a b---- | Fold 'VersionRange'.------ @since 2.2-cataVersionRange :: (VersionRangeF a -> a) -> VersionRange -> a-cataVersionRange f = c where c = f . fmap c . projectVersionRange---- | @since 2.2-embedVersionRange :: VersionRangeF VersionRange -> VersionRange-embedVersionRange (ThisVersionF v)              = ThisVersion v-embedVersionRange (LaterVersionF v)             = LaterVersion v-embedVersionRange (OrLaterVersionF v)           = OrLaterVersion v-embedVersionRange (EarlierVersionF v)           = EarlierVersion v-embedVersionRange (OrEarlierVersionF v)         = OrEarlierVersion v-embedVersionRange (MajorBoundVersionF v)        = MajorBoundVersion v-embedVersionRange (UnionVersionRangesF a b)     = UnionVersionRanges a b-embedVersionRange (IntersectVersionRangesF a b) = IntersectVersionRanges a b---- | Unfold 'VersionRange'.------ @since 2.2-anaVersionRange :: (a -> VersionRangeF a) -> a -> VersionRange-anaVersionRange g = a where a = embedVersionRange . fmap a . g---- | Refold 'VersionRange'------ @since 2.2-hyloVersionRange :: (VersionRangeF VersionRange -> VersionRange)-                 -> (VersionRange -> VersionRangeF VersionRange)-                 -> VersionRange -> VersionRange-hyloVersionRange f g = h where h = f . fmap h . g------------------------------------------------------------------------------------ Parsec & Pretty------------------------------------------------------------------------------------ |------ >>> fmap pretty (simpleParsec' CabalSpecV1_6 "== 3.2.*" :: Maybe VersionRange)--- Just >=3.2 && <3.3------ >>> fmap (prettyVersioned CabalSpecV1_6) (simpleParsec' CabalSpecV1_6 "== 3.2.*" :: Maybe VersionRange)--- Just ==3.2.*------ >>> fmap pretty (simpleParsec' CabalSpecV1_6 "-any" :: Maybe VersionRange)--- Just >=0------ >>> fmap (prettyVersioned CabalSpecV1_6) (simpleParsec' CabalSpecV1_6 "-any" :: Maybe VersionRange)--- Just >=0----instance Pretty VersionRange where-    pretty = prettyVersioned cabalSpecLatest--    prettyVersioned csv-        | csv > CabalSpecV1_6 = prettyVersionRange-        | otherwise           = prettyVersionRange16--prettyVersionRange :: VersionRange -> Disp.Doc-prettyVersionRange vr = cataVersionRange alg vr 0-  where-    alg :: VersionRangeF (Int -> Disp.Doc) -> Int -> Disp.Doc-    alg (ThisVersionF v)                _ = Disp.text "=="  <<>> pretty v-    alg (LaterVersionF v)               _ = Disp.text ">"   <<>> pretty v-    alg (OrLaterVersionF v)             _ = Disp.text ">="  <<>> pretty v-    alg (EarlierVersionF v)             _ = Disp.text "<"   <<>> pretty v-    alg (OrEarlierVersionF v)           _ = Disp.text "<="  <<>> pretty v-    alg (MajorBoundVersionF v)          _ = Disp.text "^>=" <<>> pretty v-    alg (UnionVersionRangesF r1 r2)     d = parens (d > 0)-        $ r1 1 <+> Disp.text "||" <+> r2 0-    alg (IntersectVersionRangesF r1 r2) d = parens (d > 1)-        $ r1 2 <+> Disp.text "&&" <+> r2 1--    parens True  = Disp.parens-    parens False = id---- | Don't use && and || operators. If possible.-prettyVersionRange16 :: VersionRange -> Disp.Doc-prettyVersionRange16 (IntersectVersionRanges (OrLaterVersion v) (EarlierVersion u))-    | u == wildcardUpperBound v-    = Disp.text "==" <<>> dispWild v-  where-    dispWild ver =-        Disp.hcat (Disp.punctuate (Disp.char '.')-                    (map Disp.int $ versionNumbers ver))-        <<>> Disp.text ".*"--prettyVersionRange16 vr = prettyVersionRange vr---- |------ >>> simpleParsec "^>= 3.4" :: Maybe VersionRange--- Just (MajorBoundVersion (mkVersion [3,4]))------ Small history:------ @-any@ and @-none@ removed in 3.4--- Use @>=0@ and @<0@ instead.------ >>> map (`simpleParsec'` "-none") [CabalSpecV3_0, CabalSpecV3_4] :: [Maybe VersionRange]--- [Just (EarlierVersion (mkVersion [0])),Nothing]------ Set operations are introduced in 3.0------ >>> map (`simpleParsec'` "^>= { 1.2 , 1.3 }") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe VersionRange]--- [Nothing,Just (UnionVersionRanges (MajorBoundVersion (mkVersion [1,2])) (MajorBoundVersion (mkVersion [1,3])))]------ @^>=@ is introduced in 2.0------ >>> map (`simpleParsec'` "^>=1.2") [CabalSpecV1_24, CabalSpecV2_0] :: [Maybe VersionRange]--- [Nothing,Just (MajorBoundVersion (mkVersion [1,2]))]------ @-none@ is introduced in 1.22------ >>> map (`simpleParsec'` "-none") [CabalSpecV1_20, CabalSpecV1_22] :: [Maybe VersionRange]--- [Nothing,Just (EarlierVersion (mkVersion [0]))]------ Operators are introduced in 1.8. Issues only a warning.------ >>> map (`simpleParsecW'` "== 1 || ==2") [CabalSpecV1_6, CabalSpecV1_8] :: [Maybe VersionRange]--- [Nothing,Just (UnionVersionRanges (ThisVersion (mkVersion [1])) (ThisVersion (mkVersion [2])))]------ Wild-version ranges are introduced in 1.6. Issues only a warning.------ >>> map (`simpleParsecW'` "== 1.2.*") [CabalSpecV1_4, CabalSpecV1_6] :: [Maybe VersionRange]--- [Nothing,Just (IntersectVersionRanges (OrLaterVersion (mkVersion [1,2])) (EarlierVersion (mkVersion [1,3])))]----instance Parsec VersionRange where-    parsec = askCabalSpecVersion >>= versionRangeParser versionDigitParser---- | 'VersionRange' parser parametrised by version digit parser------ - 'versionDigitParser' is used for all 'VersionRange'.--- - 'P.integral' is used for backward-compat @pkgconfig-depends@---   versions, 'PkgConfigVersionRange'.------ @since 3.0-versionRangeParser :: forall m. CabalParsing m => m Int -> CabalSpecVersion -> m VersionRange-versionRangeParser digitParser csv = expr-      where-        expr   = do P.spaces-                    t <- term-                    P.spaces-                    (do _  <- P.string "||"-                        checkOp-                        P.spaces-                        e <- expr-                        return (unionVersionRanges t e)-                     <|>-                     return t)-        term   = do f <- factor-                    P.spaces-                    (do _  <- P.string "&&"-                        checkOp-                        P.spaces-                        t <- term-                        return (intersectVersionRanges f t)-                     <|>-                     return f)-        factor = parens expr <|> prim--        prim = do-            op <- P.munch1 isOpChar P.<?> "operator"-            case op of-                "-" -> anyVersion <$ P.string "any" <|> P.string "none" *> noVersion'--                "==" -> do-                    P.spaces-                    (do (wild, v) <- verOrWild-                        checkWild wild-                        pure $ (if wild then withinVersion else thisVersion) v-                     <|>-                     (verSet' thisVersion =<< verSet))--                "^>=" -> do-                    P.spaces-                    (do (wild, v) <- verOrWild-                        when wild $ P.unexpected $-                            "wild-card version after ^>= operator"-                        majorBoundVersion' v-                     <|>-                     (verSet' majorBoundVersion =<< verSet))--                _ -> do-                    P.spaces-                    (wild, v) <- verOrWild-                    when wild $ P.unexpected $-                        "wild-card version after non-== operator: " ++ show op-                    case op of-                        ">="  -> pure $ orLaterVersion v-                        "<"   -> pure $ earlierVersion v-                        "<="  -> pure $ orEarlierVersion v-                        ">"   -> pure $ laterVersion v-                        _ -> fail $ "Unknown version operator " ++ show op--        -- Cannot be warning-        -- On 2020-03-16 there was around 27400 files on Hackage failing to parse due this-        -- For example https://hackage.haskell.org/package/haxr-3000.0.0/haxr.cabal-        ---        checkOp = when (csv < CabalSpecV1_8) $-            parsecWarning PWTVersionOperator $ unwords-                [ "version operators used."-                , "To use version operators the package needs to specify at least 'cabal-version: >= 1.8'."-                ]--        -- Cannot be warning-        -- On 2020-03-16 there was 46 files on Hackage failing to parse due this-        -- For example https://hackage.haskell.org/package/derive-0.1.2/derive.cabal-        ---        checkWild False = pure ()-        checkWild True  = when (csv < CabalSpecV1_6) $-            parsecWarning PWTVersionWildcard $ unwords-                [ "Wildcard syntax used."-                , "To use version wildcards the package needs to specify at least 'cabal-version: >= 1.6'."-                ]--        -- https://gitlab.haskell.org/ghc/ghc/issues/17752-        isOpChar '<' = True-        isOpChar '=' = True-        isOpChar '>' = True-        isOpChar '^' = True-        isOpChar '-' = csv < CabalSpecV3_4-        -- https://github.com/haskell/cabal/issues/6589-        -- Unfortunately we have must not consume the dash,-        -- as otherwise following parts may not be parsed.-        ---        -- i.e. we cannot fail here with good error.-        isOpChar _   = False--        -- -none version range is available since 1.22-        noVersion' =-            if csv >= CabalSpecV1_22-            then pure noVersion-            else fail $ unwords-                [ "-none version range used."-                , "To use this syntax the package needs to specify at least 'cabal-version: 1.22'."-                , "Alternatively, if broader compatibility is important then use"-                , "<0 or other empty range."-                ]--        -- ^>= is available since 2.0-        majorBoundVersion' v =-            if csv >= CabalSpecV2_0-            then pure $ majorBoundVersion v-            else fail $ unwords-                [ "major bounded version syntax (caret, ^>=) used."-                , "To use this syntax the package need to specify at least 'cabal-version: 2.0'."-                , "Alternatively, if broader compatibility is important then use:"-                , prettyShow $ eliminateMajorBoundSyntax $ majorBoundVersion v-                ]-          where-            eliminateMajorBoundSyntax = hyloVersionRange embed projectVersionRange-            embed (MajorBoundVersionF u) = intersectVersionRanges-                (orLaterVersion u) (earlierVersion (majorUpperBound u))-            embed vr = embedVersionRange vr--        -- version set notation (e.g. "== { 0.0.1.0, 0.0.2.0, 0.1.0.0 }")-        verSet' op vs =-            if csv >= CabalSpecV3_0-            then pure $ foldr1 unionVersionRanges (fmap op vs)-            else fail $ unwords-                [ "version set syntax used."-                , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'."-                , "Alternatively, if broader compatibility is important then use"-                , "a series of single version constraints joined with the || operator:"-                , prettyShow (foldr1 unionVersionRanges (fmap op vs))-                ]--        verSet :: CabalParsing m => m (NonEmpty Version)-        verSet = do-            _ <- P.char '{'-            P.spaces-            vs <- P.sepByNonEmpty (verPlain <* P.spaces) (P.char ',' *> P.spaces)-            _ <- P.char '}'-            pure vs--        -- a plain version without tags or wildcards-        verPlain :: CabalParsing m => m Version-        verPlain = mkVersion <$> toList <$> P.sepByNonEmpty digitParser (P.char '.')--        -- either wildcard or normal version-        verOrWild :: CabalParsing m => m (Bool, Version)-        verOrWild = do-            x <- digitParser-            verLoop (DList.singleton x)--        -- trailing: wildcard (.y.*) or normal version (optional tags) (.y.z-tag)-        verLoop :: CabalParsing m => DList.DList Int -> m (Bool, Version)-        verLoop acc = verLoop' acc-                  <|> (tags *> pure (False, mkVersion (DList.toList acc)))--        verLoop' :: CabalParsing m => DList.DList Int -> m (Bool, Version)-        verLoop' acc = do-            _ <- P.char '.'-            let digit = digitParser >>= verLoop . DList.snoc acc-            let wild  = (True, mkVersion (DList.toList acc)) <$ P.char '*'-            digit <|> wild--        parens p = P.between-            ((P.char '(' P.<?> "opening paren") >> P.spaces)-            (P.char ')' >> P.spaces)-            $ do-                a <- p-                P.spaces-                return a--        tags :: CabalParsing m => m ()-        tags = do-            ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum)-            case ts of-                []      -> pure ()-                (_ : _) -> parsecWarning PWTVersionTag "version with tags"---------------------------------- Wildcard range utilities------- | Compute next greater major version to be used as upper bound------ Example: @0.4.1@ produces the version @0.5@ which then can be used--- to construct a range @>= 0.4.1 && < 0.5@------ @since 2.2-majorUpperBound :: Version -> Version-majorUpperBound = alterVersion $ \numbers -> case numbers of-    []        -> [0,1] -- should not happen-    [m1]      -> [m1,1] -- e.g. version '1'-    (m1:m2:_) -> [m1,m2+1]---- | @since 2.2-wildcardUpperBound :: Version -> Version-wildcardUpperBound = alterVersion $-    \lowerBound -> case unsnoc lowerBound of-        Nothing      -> []-        Just (xs, x) -> xs ++ [x + 1]
− src/Distribution/Utils/Base62.hs 
@@ -1,22 +0,0 @@---- | Implementation of base-62 encoding, which we use when computing hashes--- for fully instantiated unit ids.-module Distribution.Utils.Base62 (hashToBase62) where--import GHC.Fingerprint ( Fingerprint(..), fingerprintString )-import Numeric ( showIntAtBase )-import Data.Char ( chr )---- | Hash a string using GHC's fingerprinting algorithm (a 128-bit--- MD5 hash) and then encode the resulting hash in base 62.-hashToBase62 :: String -> String-hashToBase62 s = showFingerprint $ fingerprintString s-  where-    showIntAtBase62 x = showIntAtBase 62 representBase62 x ""-    representBase62 x-        | x < 10 = chr (48 + x)-        | x < 36 = chr (65 + x - 10)-        | x < 62 = chr (97 + x - 36)-        | otherwise = '@'-    showFingerprint (Fingerprint a b) = showIntAtBase62 a ++ showIntAtBase62 b-
− src/Distribution/Utils/Generic.hs 
@@ -1,576 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE BangPatterns #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Utils--- Copyright   :  Isaac Jones, Simon Marlow 2003-2004--- License     :  BSD3---                portions Copyright (c) 2007, Galois Inc.------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ A large and somewhat miscellaneous collection of utility functions used--- throughout the rest of the Cabal lib and in other tools that use the Cabal--- lib like @cabal-install@. It has a very simple set of logging actions. It--- has low level functions for running programs, a bunch of wrappers for--- various directory and file functions that do extra logging.--module Distribution.Utils.Generic (-        -- * reading and writing files safely-        withFileContents,-        writeFileAtomic,--        -- * Unicode--        -- ** Conversions-        fromUTF8BS,-        fromUTF8LBS,--        toUTF8BS,-        toUTF8LBS,--        validateUTF8,--        -- ** File I/O-        readUTF8File,-        withUTF8FileContents,-        writeUTF8File,--        -- ** BOM-        ignoreBOM,--        -- ** Misc-        normaliseLineEndings,--        -- * generic utils-        dropWhileEndLE,-        takeWhileEndLE,-        equating,-        comparing,-        isInfixOf,-        intercalate,-        lowercase,-        isAscii,-        isAsciiAlpha,-        isAsciiAlphaNum,-        listUnion,-        listUnionRight,-        ordNub,-        ordNubBy,-        ordNubRight,-        safeHead,-        safeTail,-        safeLast,-        safeInit,-        unintersperse,-        wrapText,-        wrapLine,-        unfoldrM,-        spanMaybe,-        breakMaybe,-        unsnoc,-        unsnocNE,--        -- * Triples-        fstOf3,-        sndOf3,-        trdOf3,--        -- * FilePath stuff-        isAbsoluteOnAnyPlatform,-        isRelativeOnAnyPlatform,-  ) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Utils.String--import Data.Bits ((.&.), (.|.), shiftL)-import Data.List-    ( isInfixOf )-import qualified Data.Set as Set-import qualified Data.ByteString as SBS-import qualified Data.ByteString.Lazy as LBS--import System.Directory-    ( removeFile, renameFile )-import System.FilePath-    ( (<.>), splitFileName )-import System.IO-    ( withFile, withBinaryFile-    , openBinaryTempFileWithDefaultPermissions-    , IOMode(ReadMode), hGetContents, hClose )-import qualified Control.Exception as Exception---- -------------------------------------------------------------------------------- Helper functions---- | Wraps text to the default line width. Existing newlines are preserved.-wrapText :: String -> String-wrapText = unlines-         . map (intercalate "\n"-              . map unwords-              . wrapLine 79-              . words)-         . lines---- | Wraps a list of words to a list of lines of words of a particular width.-wrapLine :: Int -> [String] -> [[String]]-wrapLine width = wrap 0 []-  where wrap :: Int -> [String] -> [String] -> [[String]]-        wrap 0   []   (w:ws)-          | length w + 1 > width-          = wrap (length w) [w] ws-        wrap col line (w:ws)-          | col + length w + 1 > width-          = reverse line : wrap 0 [] (w:ws)-        wrap col line (w:ws)-          = let col' = col + length w + 1-             in wrap col' (w:line) ws-        wrap _ []   [] = []-        wrap _ line [] = [reverse line]---------------------------------------- Safely reading and writing files---- | Gets the contents of a file, but guarantee that it gets closed.------ The file is read lazily but if it is not fully consumed by the action then--- the remaining input is truncated and the file is closed.----withFileContents :: FilePath -> (String -> IO a) -> IO a-withFileContents name action =-  withFile name ReadMode-           (\hnd -> hGetContents hnd >>= action)---- | Writes a file atomically.------ The file is either written successfully or an IO exception is raised and--- the original file is left unchanged.------ On windows it is not possible to delete a file that is open by a process.--- This case will give an IO exception but the atomic property is not affected.----writeFileAtomic :: FilePath -> LBS.ByteString -> IO ()-writeFileAtomic targetPath content = do-  let (targetDir, targetFile) = splitFileName targetPath-  Exception.bracketOnError-    (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")-    (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)-    (\(tmpPath, handle) -> do-        LBS.hPut handle content-        hClose handle-        renameFile tmpPath targetPath)---- --------------------------------------------------------------- * Unicode stuff--- ---------------------------------------------------------------- | Decode 'String' from UTF8-encoded 'BS.ByteString'------ Invalid data in the UTF8 stream (this includes code-points @U+D800@--- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@).----fromUTF8BS :: SBS.ByteString -> String-fromUTF8BS = decodeStringUtf8 . SBS.unpack---- | Variant of 'fromUTF8BS' for lazy 'BS.ByteString's----fromUTF8LBS :: LBS.ByteString -> String-fromUTF8LBS = decodeStringUtf8 . LBS.unpack---- | Encode 'String' to UTF8-encoded 'SBS.ByteString'------ Code-points in the @U+D800@-@U+DFFF@ range will be encoded--- as the replacement character (i.e. @U+FFFD@).----toUTF8BS :: String -> SBS.ByteString-toUTF8BS = SBS.pack . encodeStringUtf8---- | Variant of 'toUTF8BS' for lazy 'BS.ByteString's----toUTF8LBS :: String -> LBS.ByteString-toUTF8LBS = LBS.pack . encodeStringUtf8---- | Check that strict 'ByteString' is valid UTF8. Returns 'Just offset' if it's not.-validateUTF8 :: SBS.ByteString -> Maybe Int-validateUTF8 = go 0 where-    go off bs = case SBS.uncons bs of-        Nothing -> Nothing-        Just (c, bs')-            | c <= 0x7F -> go (off + 1) bs'-            | c <= 0xBF -> Just off-            | c <= 0xDF -> twoBytes off c bs'-            | c <= 0xEF -> moreBytes off 3 0x800     bs' (fromIntegral $ c .&. 0xF)-            | c <= 0xF7 -> moreBytes off 4 0x10000   bs' (fromIntegral $ c .&. 0x7)-            | c <= 0xFB -> moreBytes off 5 0x200000  bs' (fromIntegral $ c .&. 0x3)-            | c <= 0xFD -> moreBytes off 6 0x4000000 bs' (fromIntegral $ c .&. 0x1)-            | otherwise -> Just off--    twoBytes off c0 bs = case SBS.uncons bs of-        Nothing        -> Just off-        Just (c1, bs')-            | c1 .&. 0xC0 == 0x80 ->-                if d >= (0x80 :: Int)-                then go (off + 2) bs'-                else Just off-            | otherwise -> Just off-          where-            d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F)--    moreBytes :: Int -> Int -> Int -> SBS.ByteString -> Int -> Maybe Int-    moreBytes off 1 overlong cs' acc-      | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc-      = go (off + 1) cs'--      | otherwise-      = Just off--    moreBytes off byteCount overlong bs acc = case SBS.uncons bs of-        Just (cn, bs') | cn .&. 0xC0 == 0x80 ->-            moreBytes (off + 1) (byteCount-1) overlong bs' ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)-        _ -> Just off-        ---- | Ignore a Unicode byte order mark (BOM) at the beginning of the input----ignoreBOM :: String -> String-ignoreBOM ('\xFEFF':string) = string-ignoreBOM string            = string---- | Reads a UTF8 encoded text file as a Unicode String------ Reads lazily using ordinary 'readFile'.----readUTF8File :: FilePath -> IO String-readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> LBS.readFile f---- | Reads a UTF8 encoded text file as a Unicode String------ Same behaviour as 'withFileContents'.----withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a-withUTF8FileContents name action =-  withBinaryFile name ReadMode-    (\hnd -> LBS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS)---- | Writes a Unicode String as a UTF8 encoded text file.------ Uses 'writeFileAtomic', so provides the same guarantees.----writeUTF8File :: FilePath -> String -> IO ()-writeUTF8File path = writeFileAtomic path . toUTF8LBS---- | Fix different systems silly line ending conventions-normaliseLineEndings :: String -> String-normaliseLineEndings [] = []-normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows-normaliseLineEndings ('\r':s)      = '\n' : normaliseLineEndings s -- old OS X-normaliseLineEndings (  c :s)      =   c  : normaliseLineEndings s---- --------------------------------------------------------------- * Common utils--- ---------------------------------------------------------------- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but--- quite a bit faster. The difference between "Data.List.dropWhileEnd" and this--- version is that the one in "Data.List" is strict in elements, but spine-lazy,--- while this one is spine-strict but lazy in elements. That's what @LE@ stands--- for - "lazy in elements".------ Example:------ >>> safeTail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1]--- *** Exception: Prelude.undefined--- ...------ >>> safeTail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1]--- [5,4,3]------ >>> take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined]--- [5,4,3]------ >>> take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined]--- *** Exception: Prelude.undefined--- ...----dropWhileEndLE :: (a -> Bool) -> [a] -> [a]-dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) []---- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but--- is usually faster (as well as being easier to read).-takeWhileEndLE :: (a -> Bool) -> [a] -> [a]-takeWhileEndLE p = fst . foldr go ([], False)-  where-    go x (rest, done)-      | not done && p x = (x:rest, False)-      | otherwise = (rest, True)---- | Like 'Data.List.nub', but has @O(n log n)@ complexity instead of--- @O(n^2)@. Code for 'ordNub' and 'listUnion' taken from Niklas Hambüchen's--- <http://github.com/nh2/haskell-ordnub ordnub> package.-ordNub :: Ord a => [a] -> [a]-ordNub = ordNubBy id---- | Like 'ordNub' and 'Data.List.nubBy'. Selects a key for each element and--- takes the nub based on that key.-ordNubBy :: Ord b => (a -> b) -> [a] -> [a]-ordNubBy f l = go Set.empty l-  where-    go !_ [] = []-    go !s (x:xs)-      | y `Set.member` s = go s xs-      | otherwise        = let !s' = Set.insert y s-                            in x : go s' xs-      where-        y = f x---- | Like "Data.List.union", but has @O(n log n)@ complexity instead of--- @O(n^2)@.-listUnion :: (Ord a) => [a] -> [a] -> [a]-listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b)-  where-    aSet = Set.fromList a---- | A right-biased version of 'ordNub'.------ Example:------ >>> ordNub [1,2,1] :: [Int]--- [1,2]------ >>> ordNubRight [1,2,1] :: [Int]--- [2,1]----ordNubRight :: (Ord a) => [a] -> [a]-ordNubRight = fst . foldr go ([], Set.empty)-  where-    go x p@(l, s) = if x `Set.member` s then p-                                        else (x:l, Set.insert x s)---- | A right-biased version of 'listUnion'.------ Example:------ >>> listUnion [1,2,3,4,3] [2,1,1]--- [1,2,3,4,3]------ >>> listUnionRight [1,2,3,4,3] [2,1,1]--- [4,3,2,1,1]----listUnionRight :: (Ord a) => [a] -> [a] -> [a]-listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b-  where-    bSet = Set.fromList b---- | A total variant of 'head'.------ @since 3.2.0.0-safeHead :: [a] -> Maybe a-safeHead []    = Nothing-safeHead (x:_) = Just x---- | A total variant of 'tail'.------ @since 3.2.0.0-safeTail :: [a] -> [a]-safeTail []     = []-safeTail (_:xs) = xs---- | A total variant of 'last'.------ @since 3.2.0.0-safeLast :: [a] -> Maybe a-safeLast []     = Nothing-safeLast (x:xs) = Just (foldl (\_ a -> a) x xs)---- | A total variant of 'init'.------ @since 3.2.0.0-safeInit :: [a] -> [a]-safeInit []     = []-safeInit [_]    = []-safeInit (x:xs) = x : safeInit xs--equating :: Eq a => (b -> a) -> b -> b -> Bool-equating p x y = p x == p y---- | Lower case string------ >>> lowercase "Foobar"--- "foobar"-lowercase :: String -> String-lowercase = map toLower---- | Ascii characters-isAscii :: Char -> Bool-isAscii c = fromEnum c < 0x80---- | Ascii letters.-isAsciiAlpha :: Char -> Bool-isAsciiAlpha c = ('a' <= c && c <= 'z')-    || ('A' <= c && c <= 'Z')---- | Ascii letters and digits.------ >>> isAsciiAlphaNum 'a'--- True------ >>> isAsciiAlphaNum 'ä'--- False----isAsciiAlphaNum :: Char -> Bool-isAsciiAlphaNum c = isAscii c && isAlphaNum c--unintersperse :: Char -> String -> [String]-unintersperse mark = unfoldr unintersperse1 where-  unintersperse1 str-    | null str = Nothing-    | otherwise =-        let (this, rest) = break (== mark) str in-        Just (this, safeTail rest)---- | Like 'break', but with 'Maybe' predicate------ >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar", "1", "2", "quu"]--- (["foo","bar"],Just (1,["2","quu"]))------ >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar"]--- (["foo","bar"],Nothing)------ @since 2.2----breakMaybe :: (a -> Maybe b) -> [a] -> ([a], Maybe (b, [a]))-breakMaybe f = go id where-    go !acc []     = (acc [], Nothing)-    go !acc (x:xs) = case f x of-        Nothing -> go (acc . (x:)) xs-        Just b  -> (acc [], Just (b, xs))---- | Like 'span' but with 'Maybe' predicate------ >>> spanMaybe listToMaybe [[1,2],[3],[],[4,5],[6,7]]--- ([1,3],[[],[4,5],[6,7]])------ >>> spanMaybe (readMaybe :: String -> Maybe Int) ["1", "2", "foo"]--- ([1,2],["foo"])------ @since 2.2----spanMaybe :: (a -> Maybe b) -> [a] -> ([b],[a])-spanMaybe _ xs@[] =  ([], xs)-spanMaybe p xs@(x:xs') = case p x of-    Just y  -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs)-    Nothing -> ([], xs)---- | 'unfoldr' with monadic action.------ >>> take 5 $ unfoldrM (\b r -> Just (r + b, b + 1)) (1 :: Int) 2--- [3,4,5,6,7]------ @since 2.2----unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a]-unfoldrM f = go where-    go b = do-        m <- f b-        case m of-            Nothing      -> return []-            Just (a, b') -> liftM (a :) (go b')---- | The opposite of 'snoc', which is the reverse of 'cons'------ Example:------ >>> unsnoc [1, 2, 3]--- Just ([1,2],3)------ >>> unsnoc []--- Nothing------ @since 3.2.0.0----unsnoc :: [a] -> Maybe ([a], a)-unsnoc []     = Nothing-unsnoc (x:xs) = Just (unsnocNE (x :| xs))---- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe'------ Example:------ >>> unsnocNE (1 :| [2, 3])--- ([1,2],3)------ >>> unsnocNE (1 :| [])--- ([],1)------ @since 3.2.0.0----unsnocNE :: NonEmpty a -> ([a], a)-unsnocNE (x:|xs) = go x xs where-    go y []     = ([], y)-    go y (z:zs) = let ~(ws, w) = go z zs in (y : ws, w)------------------------------------------------------------------------------------ Triples------------------------------------------------------------------------------------ | @since 3.4.0.0-fstOf3 :: (a,b,c) -> a-fstOf3 (a,_,_) = a---- | @since 3.4.0.0-sndOf3 :: (a,b,c) -> b-sndOf3 (_,b,_) = b---- | @since 3.4.0.0-trdOf3 :: (a,b,c) -> c-trdOf3 (_,_,c) = c---- --------------------------------------------------------------- * FilePath stuff--- ---------------------------------------------------------------- | 'isAbsoluteOnAnyPlatform' and 'isRelativeOnAnyPlatform' are like--- 'System.FilePath.isAbsolute' and 'System.FilePath.isRelative' but have--- platform independent heuristics.--- The System.FilePath exists in two versions, Windows and Posix. The two--- versions don't agree on what is a relative path and we don't know if we're--- given Windows or Posix paths.--- This results in false positives when running on Posix and inspecting--- Windows paths, like the hackage server does.--- System.FilePath.Posix.isAbsolute \"C:\\hello\" == False--- System.FilePath.Windows.isAbsolute \"/hello\" == False--- This means that we would treat paths that start with \"/\" to be absolute.--- On Posix they are indeed absolute, while on Windows they are not.------ The portable versions should be used when we might deal with paths that--- are from another OS than the host OS. For example, the Hackage Server--- deals with both Windows and Posix paths while performing the--- PackageDescription checks. In contrast, when we run 'cabal configure' we--- do expect the paths to be correct for our OS and we should not have to use--- the platform independent heuristics.-isAbsoluteOnAnyPlatform :: FilePath -> Bool--- C:\\directory-isAbsoluteOnAnyPlatform (drive:':':'\\':_) = isAlpha drive-isAbsoluteOnAnyPlatform (drive:':':'/':_)  = isAlpha drive--- UNC-isAbsoluteOnAnyPlatform ('\\':'\\':_) = True--- Posix root-isAbsoluteOnAnyPlatform ('/':_) = True-isAbsoluteOnAnyPlatform _ = False---- | @isRelativeOnAnyPlatform = not . 'isAbsoluteOnAnyPlatform'@-isRelativeOnAnyPlatform :: FilePath -> Bool-isRelativeOnAnyPlatform = not . isAbsoluteOnAnyPlatform---- $setup--- >>> import Data.Maybe--- >>> import Text.Read
src/Distribution/Utils/IOData.hs view
@@ -1,81 +1,86 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+ -- | @since 2.2.0 module Distribution.Utils.IOData-    ( -- * 'IOData' & 'IODataMode' type-      IOData (..)-    , IODataMode (..)-    , KnownIODataMode (..)-    , withIOData-    , null-    , hPutContents-    ) where+  ( -- * 'IOData' & 'IODataMode' type+    IOData (..)+  , IODataMode (..)+  , KnownIODataMode (..)+  , withIOData+  , null+  , hPutContents+  ) where  import qualified Data.ByteString.Lazy as LBS-import           Distribution.Compat.Prelude hiding (null)-import qualified Prelude+import Distribution.Compat.Prelude hiding (null) import qualified System.IO+import qualified Prelude  -- | Represents either textual or binary data passed via I/O functions -- which support binary/text mode -- -- @since 2.2 data IOData-    = IODataText String-    -- ^ How Text gets encoded is usually locale-dependent.-    | IODataBinary LBS.ByteString-    -- ^ Raw binary which gets read/written in binary mode.+  = -- | How Text gets encoded is usually locale-dependent.+    IODataText String+  | -- | Raw binary which gets read/written in binary mode.+    IODataBinary LBS.ByteString +-- | Applies a function polymorphic over 'IODataMode' to an 'IOData' value. withIOData :: IOData -> (forall mode. IODataMode mode -> mode -> r) -> r-withIOData (IODataText str) k   = k IODataModeText str+withIOData (IODataText str) k = k IODataModeText str withIOData (IODataBinary lbs) k = k IODataModeBinary lbs  -- | Test whether 'IOData' is empty null :: IOData -> Bool-null (IODataText s)   = Prelude.null s+null (IODataText s) = Prelude.null s null (IODataBinary b) = LBS.null b  instance NFData IOData where-    rnf (IODataText s)     = rnf s-    rnf (IODataBinary lbs) = rnf lbs+  rnf (IODataText s) = rnf s+  rnf (IODataBinary lbs) = rnf lbs  -- | @since 2.2 class NFData mode => KnownIODataMode mode where-    -- | 'IOData' Wrapper for 'System.IO.hGetContents'-    ---    -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all-    -- data to be read and consequently the internal file handle to be-    -- closed.-    ---    hGetIODataContents :: System.IO.Handle -> Prelude.IO mode+  -- | 'IOData' Wrapper for 'System.IO.hGetContents'+  --+  -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all+  -- data to be read and consequently the internal file handle to be+  -- closed.+  hGetIODataContents :: System.IO.Handle -> Prelude.IO mode -    toIOData   :: mode -> IOData-    iodataMode :: IODataMode mode+  toIOData :: mode -> IOData+  iodataMode :: IODataMode mode --- | @since 3.2+-- | Phantom-typed GADT representation of the mode of 'IOData', containing no+-- other data.+--+-- @since 3.2 data IODataMode mode where-    IODataModeText   :: IODataMode String-    IODataModeBinary :: IODataMode LBS.ByteString+  IODataModeText :: IODataMode String+  IODataModeBinary :: IODataMode LBS.ByteString  instance a ~ Char => KnownIODataMode [a] where-    hGetIODataContents h = do-        System.IO.hSetBinaryMode h False-        System.IO.hGetContents h+  hGetIODataContents h = do+    System.IO.hSetBinaryMode h False+    System.IO.hGetContents h -    toIOData = IODataText-    iodataMode = IODataModeText+  toIOData = IODataText+  iodataMode = IODataModeText  instance KnownIODataMode LBS.ByteString where-    hGetIODataContents h = do-        System.IO.hSetBinaryMode h True-        LBS.hGetContents h+  hGetIODataContents h = do+    System.IO.hSetBinaryMode h True+    LBS.hGetContents h -    toIOData = IODataBinary-    iodataMode = IODataModeBinary+  toIOData = IODataBinary+  iodataMode = IODataModeBinary  -- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose' ----- 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.@@ -83,10 +88,10 @@ -- @since 2.2 hPutContents :: System.IO.Handle -> IOData -> Prelude.IO () hPutContents h (IODataText c) = do-    System.IO.hSetBinaryMode h False-    System.IO.hPutStr h c-    System.IO.hClose h+  System.IO.hSetBinaryMode h False+  System.IO.hPutStr h c+  System.IO.hClose h hPutContents h (IODataBinary c) = do-    System.IO.hSetBinaryMode h True-    LBS.hPutStr h c-    System.IO.hClose h+  System.IO.hSetBinaryMode h True+  LBS.hPutStr h c+  System.IO.hClose h
+ src/Distribution/Utils/Json.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++-- | Extremely simple JSON helper. Don't do anything too fancy with this!+module Distribution.Utils.Json+  ( Json (..)+  , (.=)+  , renderJson+  ) where++import Data.ByteString.Builder+  ( Builder+  , intDec+  , stringUtf8+  , toLazyByteString+  )+import qualified Data.ByteString.Lazy as LBS+import Distribution.Compat.Prelude++data Json+  = JsonArray [Json]+  | JsonBool !Bool+  | JsonNull+  | JsonNumber !Int -- No support for Floats, Doubles just yet+  | JsonObject [(String, Json)]+  | JsonString !String+  deriving (Show)++-- | Convert a 'Json' into a 'ByteString'+renderJson :: Json -> LBS.ByteString+renderJson json = toLazyByteString (go json)+  where+    go (JsonArray objs) =+      surround "[" "]" $ mconcat $ intersperse "," $ map go objs+    go (JsonBool True) = stringUtf8 "true"+    go (JsonBool False) = stringUtf8 "false"+    go JsonNull = stringUtf8 "null"+    go (JsonNumber n) = intDec n+    go (JsonObject attrs) =+      surround "{" "}" $ mconcat $ intersperse "," $ map render attrs+      where+        render (k, v) = surround "\"" "\"" (stringUtf8 (escape k)) <> ":" <> go v+    go (JsonString s) = surround "\"" "\"" $ stringUtf8 (escape s)++surround :: Builder -> Builder -> Builder -> Builder+surround begin end middle = mconcat [begin, middle, end]++escape :: String -> String+escape ('\"' : xs) = "\\\"" <> escape xs+escape ('\\' : xs) = "\\\\" <> escape xs+escape ('\b' : xs) = "\\b" <> escape xs+escape ('\f' : xs) = "\\f" <> escape xs+escape ('\n' : xs) = "\\n" <> escape xs+escape ('\r' : xs) = "\\r" <> escape xs+escape ('\t' : xs) = "\\t" <> escape xs+escape (x : xs) = x : escape xs+escape [] = mempty++-- | A shorthand for building up 'JsonObject's+-- >>> JsonObject [ "a" .= JsonNumber 42, "b" .= JsonBool True ]+-- JsonObject [("a",JsonNumber 42),("b",JsonBool True)]+(.=) :: String -> Json -> (String, Json)+k .= v = (k, v)
src/Distribution/Utils/LogProgress.hs view
@@ -1,83 +1,84 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-}-module Distribution.Utils.LogProgress (-    LogProgress,-    runLogProgress,-    warnProgress,-    infoProgress,-    dieProgress,-    addProgressCtx,-) where+{-# LANGUAGE Rank2Types #-} -import Prelude ()+module Distribution.Utils.LogProgress+  ( LogProgress+  , runLogProgress+  , warnProgress+  , infoProgress+  , dieProgress+  , addProgressCtx+  ) where+ import Distribution.Compat.Prelude+import Prelude () +import Distribution.Simple.Utils import Distribution.Utils.Progress import Distribution.Verbosity-import Distribution.Simple.Utils import Text.PrettyPrint  type CtxMsg = Doc type LogMsg = Doc type ErrMsg = Doc -data LogEnv = LogEnv {-        le_verbosity :: Verbosity,-        le_context   :: [CtxMsg]-    }+data LogEnv = LogEnv+  { le_verbosity :: Verbosity+  , le_context :: [CtxMsg]+  }  -- | The 'Progress' monad with specialized logging and -- error messages.-newtype LogProgress a = LogProgress { unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a }+newtype LogProgress a = LogProgress {unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a}  instance Functor LogProgress where-    fmap f (LogProgress m) = LogProgress (fmap (fmap f) m)+  fmap f (LogProgress m) = LogProgress (fmap (fmap f) m)  instance Applicative LogProgress where-    pure x = LogProgress (pure (pure x))-    LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r+  pure x = LogProgress (pure (pure x))+  LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r  instance Monad LogProgress where-    return = pure-    LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r+  return = pure+  LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r  -- | Run 'LogProgress', outputting traces according to 'Verbosity', -- 'die' if there is an error. runLogProgress :: Verbosity -> LogProgress a -> IO a runLogProgress verbosity (LogProgress m) =-    foldProgress step_fn fail_fn return (m env)+  foldProgress step_fn fail_fn return (m env)   where-    env = LogEnv {-        le_verbosity = verbosity,-        le_context   = []-      }+    env =+      LogEnv+        { le_verbosity = verbosity+        , le_context = []+        }     step_fn :: LogMsg -> IO a -> IO a     step_fn doc go = do-        putStrLn (render doc)-        go+      putStrLn (render doc)+      go     fail_fn :: Doc -> IO a     fail_fn doc = do-        dieNoWrap verbosity (render doc)+      dieNoWrap verbosity (render doc)  -- | Output a warning trace message in 'LogProgress'. warnProgress :: Doc -> LogProgress () warnProgress s = LogProgress $ \env ->-    when (le_verbosity env >= normal) $-        stepProgress $-            hang (text "Warning:") 4 (formatMsg (le_context env) s)+  when (le_verbosity env >= normal) $+    stepProgress $+      hang (text "Warning:") 4 (formatMsg (le_context env) s)  -- | Output an informational trace message in 'LogProgress'. infoProgress :: Doc -> LogProgress () infoProgress s = LogProgress $ \env ->-    when (le_verbosity env >= verbose) $-        stepProgress s+  when (le_verbosity env >= verbose) $+    stepProgress s  -- | Fail the computation with an error message. dieProgress :: Doc -> LogProgress a dieProgress s = LogProgress $ \env ->-    failProgress $-        hang (text "Error:") 4 (formatMsg (le_context env) s)+  failProgress $+    hang (text "Error:") 4 (formatMsg (le_context env) s)  -- | Format a message with context. (Something simple for now.) formatMsg :: [CtxMsg] -> Doc -> Doc@@ -86,4 +87,4 @@ -- | Add a message to the error/warning context. addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a addProgressCtx s (LogProgress m) = LogProgress $ \env ->-    m env { le_context = s : le_context env }+  m env{le_context = s : le_context env}
− src/Distribution/Utils/MD5.hs 
@@ -1,79 +0,0 @@-module Distribution.Utils.MD5 (-    MD5,-    showMD5,-    md5,-    -- * Helpers-    md5FromInteger,-    -- * Binary-    binaryPutMD5,-    binaryGetMD5,-    ) where--import Data.Binary      (Get, Put)-import Data.Binary.Get  (getWord64le)-import Data.Binary.Put  (putWord64le)-import Data.Bits        (complement, shiftR, (.&.))-import Foreign.Ptr      (castPtr)-import GHC.Fingerprint  (Fingerprint (..), fingerprintData)-import Numeric          (showHex)-import System.IO.Unsafe (unsafeDupablePerformIO)--import qualified Data.ByteString        as BS-import qualified Data.ByteString.Unsafe as BS--type MD5 = Fingerprint---- | Show 'MD5' in human readable form------ >>> showMD5 (Fingerprint 123 456)--- "000000000000007b00000000000001c8"------ >>> showMD5 $ md5 $ BS.pack [0..127]--- "37eff01866ba3f538421b30b7cbefcac"------ @since  3.2.0.0-showMD5 :: MD5 -> String-showMD5 (Fingerprint a b) = pad a' ++ pad b' where-    a' = showHex a ""-    b' = showHex b ""-    pad s = replicate (16 - length s) '0' ++ s---- | @since  3.2.0.0-md5 :: BS.ByteString -> MD5-md5 bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) ->-    fingerprintData (castPtr ptr) len---- | @since  3.2.0.0-binaryPutMD5 :: MD5 -> Put-binaryPutMD5 (Fingerprint a b) = do-    putWord64le a-    putWord64le b---- | @since  3.2.0.0-binaryGetMD5 :: Get MD5-binaryGetMD5 = do-    a <- getWord64le-    b <- getWord64le-    return (Fingerprint a b)---- |------ >>> showMD5 $ md5FromInteger 0x37eff01866ba3f538421b30b7cbefcac--- "37eff01866ba3f538421b30b7cbefcac"------ Note: the input is truncated:------ >>> showMD5 $ md5FromInteger 0x1230000037eff01866ba3f538421b30b7cbefcac--- "37eff01866ba3f538421b30b7cbefcac"------ Yet, negative numbers are not a problem...------ >>> showMD5 $ md5FromInteger (-1)--- "ffffffffffffffffffffffffffffffff"------ @since 3.4.0.0-md5FromInteger :: Integer -> MD5-md5FromInteger i = Fingerprint hi lo where-    mask = complement 0-    lo   = mask .&. fromInteger i-    hi   = mask .&. fromInteger (i `shiftR` 64)
src/Distribution/Utils/MapAccum.hs view
@@ -1,34 +1,26 @@-{-# LANGUAGE CPP #-} module Distribution.Utils.MapAccum (mapAccumM) where  import Distribution.Compat.Prelude import Prelude ()  -- Like StateT but with return tuple swapped-newtype StateM s m a = StateM { runStateM :: s -> m (s, a) }+newtype StateM s m a = StateM {runStateM :: s -> m (s, a)}  instance Functor m => Functor (StateM s m) where-    fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s)+  fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s) -instance-#if __GLASGOW_HASKELL__ < 709-    (Functor m, Monad m)-#else-    Monad m-#endif-    => Applicative (StateM s m) where-    pure x = StateM $ \s -> return (s, x)-    StateM f <*> StateM x = StateM $ \s -> do (s', f') <- f s-                                              (s'', x') <- x s'-                                              return (s'', f' x')+instance Monad m => Applicative (StateM s m) where+  pure x = StateM $ \s -> return (s, x)+  StateM f <*> StateM x = StateM $ \s -> do+    (s', f') <- f s+    (s'', x') <- x s'+    return (s'', f' x')  -- | Monadic variant of 'mapAccumL'.-mapAccumM ::-#if __GLASGOW_HASKELL__ < 709-    (Functor m, Monad m, Traversable t)-#else-    (Monad m, Traversable t)-#endif-          => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c)+mapAccumM+  :: (Monad m, Traversable t)+  => (a -> b -> m (a, c))+  -> a+  -> t b+  -> m (a, t c) mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' x)) t) s-
src/Distribution/Utils/NubList.hs view
@@ -1,17 +1,16 @@-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Utils.NubList-    ( NubList    -- opaque-    , toNubList  -- smart construtor-    , fromNubList-    , overNubList -    , NubListR-    , toNubListR-    , fromNubListR-    , overNubListR-    ) where+module Distribution.Utils.NubList+  ( NubList -- opaque+  , toNubList -- smart constructor+  , fromNubList+  , overNubList+  , NubListR+  , toNubListR+  , fromNubListR+  , overNubListR+  ) where  import Distribution.Compat.Prelude import Prelude ()@@ -21,9 +20,8 @@ import qualified Text.Read as R  -- | NubList : A de-duplicated list that maintains the original order.-newtype NubList a =-    NubList { fromNubList :: [a] }-    deriving (Eq, Generic, Typeable)+newtype NubList a = NubList {fromNubList :: [a]}+  deriving (Eq, Generic)  -- NubList assumes that nub retains the list order while removing duplicate -- elements (keeping the first occurrence). Documentation for "Data.List.nub"@@ -39,7 +37,7 @@ overNubList f (NubList list) = toNubList . f $ list  -- | Monoid operations on NubLists.--- For a valid Monoid instance we need to satistfy the required monoid laws;+-- For a valid Monoid instance we need to satisfy the required monoid laws; -- identity, associativity and closure. -- -- Identity : by inspection:@@ -51,30 +49,29 @@ -- -- Closure : appending two lists of type a and removing duplicates obviously -- does not change the type.- instance Ord a => Monoid (NubList a) where-    mempty = NubList []-    mappend = (<>)+  mempty = NubList []+  mappend = (<>)  instance Ord a => Semigroup (NubList a) where-    (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys+  (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys  instance Show a => Show (NubList a) where-    show (NubList list) = show list+  show (NubList list) = show list  instance (Ord a, Read a) => Read (NubList a) where-    readPrec = readNubList toNubList+  readPrec = readNubList toNubList  -- | Helper used by NubList/NubListR's Read instances.-readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a)+readNubList :: Read a => ([a] -> l a) -> R.ReadPrec (l a) readNubList listToL = R.parens . R.prec 10 $ fmap listToL R.readPrec  -- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we -- just pull off constructor and put the list. For 'get', we get the list and -- make a 'NubList' out of it using 'toNubList'. instance (Ord a, Binary a) => Binary (NubList a) where-    put (NubList l) = put l-    get = fmap toNubList get+  put (NubList l) = put l+  get = fmap toNubList get  instance Structured a => Structured (NubList a) @@ -82,9 +79,8 @@ -- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@, -- unlike the normal 'NubList', which is left-biased. Built on top of -- 'ordNubRight' and 'listUnionRight'.-newtype NubListR a =-    NubListR { fromNubListR :: [a] }-    deriving Eq+newtype NubListR a = NubListR {fromNubListR :: [a]}+  deriving (Eq)  -- | Smart constructor for the NubListR type. toNubListR :: Ord a => [a] -> NubListR a@@ -105,4 +101,4 @@   show (NubListR list) = show list  instance (Ord a, Read a) => Read (NubListR a) where-    readPrec = readNubList toNubListR+  readPrec = readNubList toNubListR
− src/Distribution/Utils/Path.hs 
@@ -1,103 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE StandaloneDeriving #-}-module Distribution.Utils.Path (-    -- * Symbolic path-    SymbolicPath,-    getSymbolicPath,-    sameDirectory,-    unsafeMakeSymbolicPath,-    -- * Path ends-    PackageDir,-    SourceDir,-    LicenseFile,-    IsDir,-) where--import Prelude ()-import Distribution.Compat.Prelude--import Distribution.Parsec-import Distribution.Pretty-import Distribution.Utils.Generic (isAbsoluteOnAnyPlatform)--import qualified Distribution.Compat.CharParsing as P--- import qualified Text.PrettyPrint                as Disp------------------------------------------------------------------------------------ * SymbolicPath------------------------------------------------------------------------------------ | Symbolic paths.------ These paths are system independent and relative.--- They are *symbolic* which means we cannot perform any 'IO'--- until we interpret them.----newtype SymbolicPath from to = SymbolicPath FilePath-  deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)--instance Binary (SymbolicPath from to)-instance (Typeable from, Typeable to) => Structured (SymbolicPath from to)-instance NFData (SymbolicPath from to) where rnf = genericRnf---- | Extract underlying 'FilePath'.------ Avoid using this in new code.----getSymbolicPath :: SymbolicPath from to -> FilePath-getSymbolicPath (SymbolicPath p) = p--sameDirectory :: (IsDir from, IsDir to) => SymbolicPath from to-sameDirectory = SymbolicPath "."---- | Make 'SymbolicPath' without performing any checks.-unsafeMakeSymbolicPath :: FilePath -> SymbolicPath from to-unsafeMakeSymbolicPath = SymbolicPath------------------------------------------------------------------------------------ ** Parsing and pretty printing----------------------------------------------------------------------------------instance Parsec (SymbolicPath from to) where-    parsec = do-        token <- parsecToken-        if null token then P.unexpected "empty FilePath"-        else if isAbsoluteOnAnyPlatform token then P.unexpected "absolute FilePath"-        else return (SymbolicPath token) -- TODO: normalise--instance Pretty (SymbolicPath from to) where-    pretty = showFilePath . getSymbolicPath------------------------------------------------------------------------------------ * Composition------------------------------------------------------------------------------------ TODO--- infixr 5 <//>------ -- | Path composition--- ----- -- We don't reuse @</>@ name to not clash with "System.FilePath".--- ----- (<//>) :: path a b -> path b c -> path a c------------------------------------------------------------------------------------ * Path ends------------------------------------------------------------------------------------ | Class telling that index is for directories.-class IsDir dir--data PackageDir deriving (Typeable)-data SourceDir  deriving (Typeable)--data LicenseFile deriving (Typeable)---- These instances needs to be derived standalone at least on GHC-7.6-deriving instance Data PackageDir-deriving instance Data SourceDir-deriving instance Data LicenseFile--instance IsDir PackageDir-instance IsDir SourceDir
src/Distribution/Utils/Progress.hs view
@@ -1,22 +1,21 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-}+ -- Note: This module was copied from cabal-install.  -- | A progress monad, which we use to report failure and logging from -- otherwise pure code. module Distribution.Utils.Progress-    ( Progress-    , stepProgress-    , failProgress-    , foldProgress-    ) where+  ( Progress+  , stepProgress+  , failProgress+  , foldProgress+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import qualified Data.Monoid as Mon - -- | A type to represent the unfolding of an expensive long running -- calculation that may fail (or maybe not expensive, but complicated!) -- We may get intermediate steps before the final@@ -25,14 +24,13 @@ -- TODO: Apply Codensity to avoid left-associativity problem. -- See http://comonad.com/reader/2011/free-monads-for-less/ and -- http://blog.ezyang.com/2012/01/problem-set-the-codensity-transformation/----data Progress step fail done = Step step (Progress step fail done)-                             | Fail fail-                             | Done done+data Progress step fail done+  = Step step (Progress step fail done)+  | Fail fail+  | Done done   deriving (Functor)  -- | Emit a step and then continue.--- stepProgress :: step -> Progress step fail () stepProgress step = Step step (Done ()) @@ -46,22 +44,26 @@ -- Eg to convert into a simple 'Either' result use: -- -- > foldProgress (flip const) Left Right----foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)-             -> Progress step fail done -> a+foldProgress+  :: (step -> a -> a)+  -> (fail -> a)+  -> (done -> a)+  -> Progress step fail done+  -> a foldProgress step err done = fold-  where fold (Step s p) = step s (fold p)-        fold (Fail f)   = err f-        fold (Done r)   = done r+  where+    fold (Step s p) = step s (fold p)+    fold (Fail f) = err f+    fold (Done r) = done r  instance Monad (Progress step fail) where-  return   = pure-  p >>= f  = foldProgress Step Fail f p+  return = pure+  p >>= f = foldProgress Step Fail f p  instance Applicative (Progress step fail) where-  pure a  = Done a+  pure a = Done a   p <*> x = foldProgress Step Fail (flip fmap x) p  instance Monoid fail => Alternative (Progress step fail) where-  empty   = Fail Mon.mempty+  empty = Fail Mon.mempty   p <|> q = foldProgress Step (const q) Done p
− src/Distribution/Utils/ShortText.hs 
@@ -1,159 +0,0 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}---- | Compact representation of short 'Strings'------ This module is designed to be import qualifeid------ @--- import Distribution.Utils.ShortText (ShortText)--- import qualified Distribution.Utils.ShortText as ShortText--- @-module Distribution.Utils.ShortText-    ( -- * 'ShortText' type-      ShortText-    , toShortText-    , fromShortText-    , unsafeFromUTF8BS--      -- * Operations-    , null-    , length--      -- * internal utilities-    , decodeStringUtf8-    , encodeStringUtf8-    ) where--import Distribution.Compat.Prelude hiding (length, null)-import Prelude ()--import Distribution.Utils.String     (decodeStringUtf8, encodeStringUtf8)-import Distribution.Utils.Structured (Structured (..), nominalStructure)--#if defined(MIN_VERSION_bytestring)-# if MIN_VERSION_bytestring(0,10,4)-# define HAVE_SHORTBYTESTRING 1-# endif-#endif---- Hack for GHC bootstrapping------ Currently (as of GHC 8.1), GHC bootstraps Cabal by building--- binary and Cabal in one giant ghc --make command.  This--- means no MIN_VERSION_binary macro is available.------ We could try to cleverly figure something out in this case,--- but there is a better plan: just use the unoptimized version--- of the Binary instance.  We're not going to use it for anything--- real in any case.------ WARNING: Don't use MIN_VERSION_binary to smooth over a BC-break!----#ifndef MIN_VERSION_binary-#define MIN_VERSION_binary(x, y, z) 0-#endif--import qualified Data.ByteString as BS-import qualified Data.List       as List--#if HAVE_SHORTBYTESTRING-import qualified Data.ByteString.Short as BS.Short-#else-import Distribution.Utils.Generic (fromUTF8BS)-#endif---- | Construct 'ShortText' from 'String'-toShortText :: String -> ShortText---- | Convert 'ShortText' to 'String'-fromShortText :: ShortText -> String---- | Convert from UTF-8 encoded strict 'ByteString'.------ @since 3.2.0.0-unsafeFromUTF8BS :: BS.ByteString -> ShortText---- | Text whether 'ShortText' is empty.------ @since 3.2.0.0-null :: ShortText -> Bool---- | Compact representation of short 'Strings'------ The data is stored internally as UTF8 in an--- 'BS.Short.ShortByteString' when compiled against @bytestring >=--- 0.10.4@, and otherwise the fallback is to use plain old non-compat--- '[Char]'.------ Note: This type is for internal uses (such as e.g. 'PackageName')--- and shall not be exposed in Cabal's API------ @since 2.0.0.2-#if HAVE_SHORTBYTESTRING-newtype ShortText = ST { unST :: BS.Short.ShortByteString }-                  deriving (Eq,Ord,Generic,Data,Typeable)--# if MIN_VERSION_binary(0,8,1)-instance Binary ShortText where-    put = put . unST-    get = fmap ST get-# else-instance Binary ShortText where-    put = put . BS.Short.fromShort . unST-    get = fmap (ST . BS.Short.toShort) get-# endif---toShortText = ST . BS.Short.pack . encodeStringUtf8--fromShortText = decodeStringUtf8 . BS.Short.unpack . unST--unsafeFromUTF8BS = ST . BS.Short.toShort--null = BS.Short.null . unST-#else-newtype ShortText = ST { unST :: String }-                  deriving (Eq,Ord,Generic,Data,Typeable)--instance Binary ShortText where-    put = put . encodeStringUtf8 . unST-    get = fmap (ST . decodeStringUtf8) get--toShortText = ST--fromShortText = unST--unsafeFromUTF8BS = ST . fromUTF8BS--null = List.null . unST-#endif--instance Structured ShortText where structure = nominalStructure--instance NFData ShortText where-    rnf = rnf . unST--instance Show ShortText where-    show = show . fromShortText--instance Read ShortText where-    readsPrec p = map (first toShortText) . readsPrec p--instance Semigroup ShortText where-    ST a <> ST b = ST (mappend a b)--instance Monoid ShortText where-    mempty = ST mempty-    mappend = (<>)--instance IsString ShortText where-    fromString = toShortText---- | /O(n)/. Length in characters. /Slow/ as converts to string.------ @since 3.2.0.0-length :: ShortText -> Int-length = List.length . fromShortText--- Note: avoid using it, we use it @cabal check@ implementation, where it's ok.
− src/Distribution/Utils/String.hs 
@@ -1,93 +0,0 @@-module Distribution.Utils.String-    ( -- * Encode to/from UTF8-      decodeStringUtf8-    , encodeStringUtf8-    ) where--import Data.Word-import Data.Bits-import Data.Char (chr,ord)---- | Decode 'String' from UTF8-encoded octets.------ Invalid data in the UTF8 stream (this includes code-points @U+D800@--- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@).------ See also 'encodeStringUtf8'-decodeStringUtf8 :: [Word8] -> String-decodeStringUtf8 = go-  where-    go :: [Word8] -> String-    go []       = []-    go (c : cs)-      | c <= 0x7F = chr (fromIntegral c) : go cs-      | c <= 0xBF = replacementChar : go cs-      | c <= 0xDF = twoBytes c cs-      | c <= 0xEF = moreBytes 3 0x800     cs (fromIntegral $ c .&. 0xF)-      | c <= 0xF7 = moreBytes 4 0x10000   cs (fromIntegral $ c .&. 0x7)-      | c <= 0xFB = moreBytes 5 0x200000  cs (fromIntegral $ c .&. 0x3)-      | c <= 0xFD = moreBytes 6 0x4000000 cs (fromIntegral $ c .&. 0x1)-      | otherwise   = replacementChar : go cs--    twoBytes :: Word8 -> [Word8] -> String-    twoBytes c0 (c1:cs')-      | c1 .&. 0xC0 == 0x80-      = let d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6)-             .|. fromIntegral (c1 .&. 0x3F)-         in if d >= 0x80-               then  chr d                : go cs'-               else  replacementChar      : go cs'-    twoBytes _ cs' = replacementChar      : go cs'--    moreBytes :: Int -> Int -> [Word8] -> Int -> [Char]-    moreBytes 1 overlong cs' acc-      | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc-      = chr acc : go cs'--      | otherwise-      = replacementChar : go cs'--    moreBytes byteCount overlong (cn:cs') acc-      | cn .&. 0xC0 == 0x80-      = moreBytes (byteCount-1) overlong cs'-          ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)--    moreBytes _ _ cs' _-      = replacementChar : go cs'--    replacementChar = '\xfffd'----- | Encode 'String' to a list of UTF8-encoded octets------ Code-points in the @U+D800@-@U+DFFF@ range will be encoded--- as the replacement character (i.e. @U+FFFD@).------ See also 'decodeUtf8'-encodeStringUtf8 :: String -> [Word8]-encodeStringUtf8 []        = []-encodeStringUtf8 (c:cs)-  | c <= '\x07F' = w8-                 : encodeStringUtf8 cs-  | c <= '\x7FF' = (0xC0 .|.  w8ShiftR  6          )-                 : (0x80 .|. (w8          .&. 0x3F))-                 : encodeStringUtf8 cs-  | c <= '\xD7FF'= (0xE0 .|.  w8ShiftR 12          )-                 : (0x80 .|. (w8ShiftR  6 .&. 0x3F))-                 : (0x80 .|. (w8          .&. 0x3F))-                 : encodeStringUtf8 cs-  | c <= '\xDFFF'= 0xEF : 0xBF : 0xBD -- U+FFFD-                 : encodeStringUtf8 cs-  | c <= '\xFFFF'= (0xE0 .|.  w8ShiftR 12          )-                 : (0x80 .|. (w8ShiftR  6 .&. 0x3F))-                 : (0x80 .|. (w8          .&. 0x3F))-                 : encodeStringUtf8 cs-  | otherwise    = (0xf0 .|.  w8ShiftR 18          )-                 : (0x80 .|. (w8ShiftR 12 .&. 0x3F))-                 : (0x80 .|. (w8ShiftR  6 .&. 0x3F))-                 : (0x80 .|. (w8          .&. 0x3F))-                 : encodeStringUtf8 cs-  where-    w8 = fromIntegral (ord c) :: Word8-    w8ShiftR :: Int -> Word8-    w8ShiftR = fromIntegral . shiftR (ord c)
− src/Distribution/Utils/Structured.hs 
@@ -1,477 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DefaultSignatures   #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE PolyKinds           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE TypeOperators       #-}-#if __GLASGOW_HASKELL__ >= 711-{-# LANGUAGE PatternSynonyms     #-}-#endif-#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE TypeInType          #-}-#endif--- |------ Copyright: (c) 2019 Oleg Grenrus------ Structurally tag binary serialisaton stream.--- Useful when most 'Binary' instances are 'Generic' derived.------ Say you have a data type------ @--- data Record = Record---   { _recordFields  :: HM.HashMap Text (Integer, ByteString)---   , _recordEnabled :: Bool---   }---   deriving (Eq, Show, Generic)------ instance 'Binary' Record--- instance 'Structured' Record--- @------ then you can serialise and deserialise @Record@ values with a structure tag by simply------ @--- 'structuredEncode' record :: 'LBS.ByteString'--- 'structuredDecode' lbs :: IO Record--- @------ If structure of @Record@ changes in between, deserialisation will fail early.------ Technically, 'Structured' is not related to 'Binary', and may--- be useful in other uses.----module Distribution.Utils.Structured (-    -- * Encoding and decoding-    -- | These functions operate like @binary@'s counterparts,-    -- but the serialised version has a structure hash in front.-    structuredEncode,-    structuredEncodeFile,-    structuredDecode,-    structuredDecodeOrFailIO,-    structuredDecodeFileOrFail,-    -- * Structured class-    Structured (structure),-    MD5,-    structureHash,-    structureBuilder,-    genericStructure,-    GStructured,-    nominalStructure,-    containerStructure,-    -- * Structure type-    Structure (..),-    Tag (..),-    TypeName,-    ConstructorName,-    TypeVersion,-    SopStructure,-    hashStructure,-    typeVersion,-    typeName,-    ) where--import Data.Int           (Int16, Int32, Int64, Int8)-import Data.List.NonEmpty (NonEmpty)-import Data.Proxy         (Proxy (..))-import Data.Ratio         (Ratio)-import Data.Word          (Word, Word16, Word32, Word64, Word8)--import qualified Control.Monad.Trans.State.Strict as State--import Control.Exception (ErrorCall (..), catch, evaluate)--import GHC.Generics--import qualified Data.ByteString              as BS-import qualified Data.ByteString.Lazy         as LBS-#if MIN_VERSION_bytestring(0,10,4)-import qualified Data.ByteString.Builder      as Builder-#else-import qualified Data.ByteString.Lazy.Builder as Builder-#endif-import qualified Data.IntMap                  as IM-import qualified Data.IntSet                  as IS-import qualified Data.Map                     as Map-import qualified Data.Sequence                as Seq-import qualified Data.Set                     as Set-import qualified Data.Text                    as T-import qualified Data.Text.Lazy               as LT-import qualified Data.Time                    as Time-import qualified Distribution.Compat.Binary   as Binary--#ifdef MIN_VERSION_aeson-import qualified Data.Aeson as Aeson-#endif--#if __GLASGOW_HASKELL__ >= 800-import Data.Kind (Type)-#else-#define Type *-#endif--import Distribution.Compat.Typeable (Typeable, TypeRep, typeRep)-import Distribution.Utils.MD5--import Data.Monoid (mconcat)--import qualified Data.Semigroup-import qualified Data.Foldable--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative (pure)-import Data.Traversable (traverse)-#endif--#if !MIN_VERSION_base(4,7,0)-import Data.Typeable (Typeable1, typeOf1)-#endif------------------------------------------------------------------------------------- Types----------------------------------------------------------------------------------type TypeName        = String-type ConstructorName = String---- | A sematic version of a data type. Usually 0.-type TypeVersion     = Word32---- | Structure of a datatype.------ It can be infinite, as far as 'TypeRep's involved are finite.--- (e.g. polymorphic recursion might cause troubles).----data Structure-    = Nominal   !TypeRep !TypeVersion TypeName [Structure]  -- ^ nominal, yet can be parametrised by other structures.-    | Newtype   !TypeRep !TypeVersion TypeName Structure    -- ^ a newtype wrapper-    | Structure !TypeRep !TypeVersion TypeName SopStructure -- ^ sum-of-products structure-  deriving (Eq, Ord, Show, Generic)--type SopStructure = [(ConstructorName, [Structure])]---- | A MD5 hash digest of 'Structure'.-hashStructure :: Structure -> MD5-hashStructure = md5 . LBS.toStrict . Builder.toLazyByteString . structureBuilder---- | A van-Laarhoven lens into 'TypeVersion' of 'Structure'------ @--- 'typeVersion' :: Lens' 'Structure' 'TypeVersion'--- @-typeVersion :: Functor f => (TypeVersion -> f TypeVersion) -> Structure -> f Structure-typeVersion f (Nominal   t v n s) = fmap (\v' -> Nominal   t v' n s) (f v)-typeVersion f (Newtype   t v n s) = fmap (\v' -> Newtype   t v' n s) (f v)-typeVersion f (Structure t v n s) = fmap (\v' -> Structure t v' n s) (f v)---- | A van-Laarhoven lens into 'TypeName' of 'Structure'------ @--- 'typeName' :: Lens' 'Structure' 'TypeName'--- @-typeName :: Functor f => (TypeName -> f TypeName) -> Structure -> f Structure-typeName f (Nominal   t v n s) = fmap (\n' -> Nominal   t v n' s) (f n)-typeName f (Newtype   t v n s) = fmap (\n' -> Newtype   t v n' s) (f n)-typeName f (Structure t v n s) = fmap (\n' -> Structure t v n' s) (f n)------------------------------------------------------------------------------------ Builder------------------------------------------------------------------------------------ | Flatten 'Structure' into something we can calculate hash of.------ As 'Structure' can be potentially infinite. For mutually recursive types,--- we keep track of 'TypeRep's, and put just 'TypeRep' name when it's occurred--- another time.-structureBuilder :: Structure -> Builder.Builder-structureBuilder s0 = State.evalState (go s0) Map.empty where-    go :: Structure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder-    go (Nominal   t v n s) = withTypeRep t $ do-        s' <- traverse go s-        return $ mconcat $ Builder.word8 1 : Builder.word32LE v :  Builder.stringUtf8 n : s'--    go (Newtype   t v n s) = withTypeRep t $ do-        s' <- go s-        return $ mconcat [Builder.word8 2, Builder.word32LE v, Builder.stringUtf8 n, s']--    go (Structure t v n s) = withTypeRep t $ do-        s' <- goSop s-        return $ mconcat [Builder.word8 3, Builder.word32LE v, Builder.stringUtf8 n, s']--    withTypeRep t k = do-        acc <- State.get-        case insert t acc of-            Nothing -> return $ mconcat [ Builder.word8 0, Builder.stringUtf8 (show t) ]-            Just acc' -> do-                State.put acc'-                k--    goSop :: SopStructure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder-    goSop sop = do-        parts <- traverse part sop-        return $ mconcat parts--    part (cn, s) = do-        s' <- traverse go s-        return $ Data.Monoid.mconcat [ Builder.stringUtf8 cn, mconcat s' ]--    insert :: TypeRep -> Map.Map String (NonEmpty TypeRep) -> Maybe (Map.Map String (NonEmpty TypeRep))-    insert tr m = case Map.lookup trShown m of-        Nothing                              -> inserted-        Just ne | tr `Data.Foldable.elem` ne -> Nothing-                | otherwise                  -> inserted-      where-        inserted = Just (Map.insertWith (Data.Semigroup.<>) trShown (pure tr) m)-        trShown  = show tr------------------------------------------------------------------------------------ Classes------------------------------------------------------------------------------------ | Class of types with a known 'Structure'.------ For regular data types 'Structured' can be derived generically.------ @--- data Record = Record { a :: Int, b :: Bool, c :: [Char] } deriving ('Generic')--- instance 'Structured' Record--- @------ @since 3.2.0.0----class Typeable a => Structured a where-    structure :: Proxy a -> Structure-    default structure :: (Generic a, GStructured (Rep a)) => Proxy a -> Structure-    structure = genericStructure--    -- This member is hidden. It's there to precalc-    structureHash' :: Tagged a MD5-    structureHash' = Tagged (hashStructure (structure (Proxy :: Proxy a)))---- private Tagged-newtype Tagged a b = Tagged { untag :: b }---- | Semantically @'hashStructure' . 'structure'@.-structureHash :: forall a. Structured a => Proxy a -> MD5-structureHash _ = untag (structureHash' :: Tagged a MD5)------------------------------------------------------------------------------------ Functions------------------------------------------------------------------------------------ | Structured 'Binary.encode'.--- Encode a value to using binary serialisation to a lazy 'LBS.ByteString'.--- Encoding starts with 16 byte large structure hash.-structuredEncode-  :: forall a. (Binary.Binary a, Structured a)-  => a -> LBS.ByteString-structuredEncode x = Binary.encode (Tag :: Tag a, x)---- | Lazily serialise a value to a file-structuredEncodeFile :: (Binary.Binary a, Structured a) => FilePath -> a -> IO ()-structuredEncodeFile f = LBS.writeFile f . structuredEncode---- | Structured 'Binary.decode'.--- Decode a value from a lazy 'LBS.ByteString', reconstructing the original structure.--- Throws pure exception on invalid inputs.-structuredDecode-  :: forall a. (Binary.Binary a, Structured a)-  => LBS.ByteString -> a-structuredDecode lbs = snd (Binary.decode lbs :: (Tag a, a))--structuredDecodeOrFailIO :: (Binary.Binary a, Structured a) => LBS.ByteString -> IO (Either String a)-structuredDecodeOrFailIO bs =-    catch (evaluate (structuredDecode bs) >>= return . Right) handler-  where-#if MIN_VERSION_base(4,9,0)-    handler (ErrorCallWithLocation str _) = return $ Left str-#else-    handler (ErrorCall str) = return $ Left str-#endif---- | Lazily reconstruct a value previously written to a file.-structuredDecodeFileOrFail :: (Binary.Binary a, Structured a) => FilePath -> IO (Either String a)-structuredDecodeFileOrFail f = structuredDecodeOrFailIO =<< LBS.readFile f------------------------------------------------------------------------------------ Helper data----------------------------------------------------------------------------------data Tag a = Tag--instance Structured a => Binary.Binary (Tag a) where-    get = do-        actual <- binaryGetMD5-        if actual == expected-        then return Tag-        else fail $ concat-            [ "Non-matching structured hashes: "-            , showMD5 actual-            , "; expected: "-            , showMD5 expected-            ]-      where-        expected = untag (structureHash' :: Tagged a MD5)--    put _ = binaryPutMD5 expected-      where-        expected = untag (structureHash' :: Tagged a MD5)------------------------------------------------------------------------------------ Smart constructors------------------------------------------------------------------------------------ | Use 'Typeable' to infer name-nominalStructure :: Typeable a => Proxy a -> Structure-nominalStructure p = Nominal tr 0 (show tr) [] where-    tr = typeRep p--#if MIN_VERSION_base(4,7,0)-containerStructure :: forall f a. (Typeable f, Structured a) => Proxy (f a) -> Structure-containerStructure _ = Nominal faTypeRep 0 (show fTypeRep)-    [ structure (Proxy :: Proxy a)-    ]-  where-    fTypeRep  = typeRep (Proxy :: Proxy f)-    faTypeRep = typeRep (Proxy :: Proxy (f a))--#else-containerStructure :: forall f a. (Typeable1 f, Structured a) => Proxy (f a) -> Structure-containerStructure _ = Nominal faTypeRep 0 (show fTypeRep)-    [ structure (Proxy :: Proxy a)-    ]-  where-    fTypeRep  = typeOf1 (undefined :: f ())-    faTypeRep = typeRep (Proxy :: Proxy (f a))-#endif------------------------------------------------------------------------------------ Generic------------------------------------------------------------------------------------ | Derive 'structure' genrically.-genericStructure :: forall a. (Typeable a, Generic a, GStructured (Rep a)) => Proxy a -> Structure-genericStructure _ = gstructured (typeRep (Proxy :: Proxy a)) (Proxy :: Proxy (Rep a)) 0---- | Used to implement 'genericStructure'.-class GStructured (f :: Type -> Type) where-    gstructured :: TypeRep -> Proxy f -> TypeVersion -> Structure--instance (i ~ D, Datatype c, GStructuredSum f) => GStructured (M1 i c f) where-    gstructured tr _ v = case sop of-#if MIN_VERSION_base(4,7,0)-        [(_, [s])] | isNewtype p -> Newtype tr v name s-#endif-        _                        -> Structure tr v name sop-      where-        p    = undefined :: M1 i c f ()-        name = datatypeName p-        sop  = gstructuredSum (Proxy :: Proxy f) []--class GStructuredSum (f :: Type -> Type) where-    gstructuredSum :: Proxy f -> SopStructure -> SopStructure--instance (i ~ C, Constructor c, GStructuredProd f) => GStructuredSum (M1 i c f) where-    gstructuredSum _ xs = (name, prod) : xs-      where-        name = conName (undefined :: M1 i c f ())-        prod = gstructuredProd (Proxy :: Proxy f) []--instance (GStructuredSum f, GStructuredSum g) => GStructuredSum (f :+: g) where-    gstructuredSum _ xs-        = gstructuredSum (Proxy :: Proxy f)-        $ gstructuredSum (Proxy :: Proxy g) xs--instance GStructuredSum V1 where-    gstructuredSum _ = id--class GStructuredProd (f :: Type -> Type) where-    gstructuredProd :: Proxy f -> [Structure] -> [Structure]--instance (i ~ S, GStructuredProd f) => GStructuredProd (M1 i c f) where-    gstructuredProd _ = gstructuredProd (Proxy :: Proxy f)--instance Structured c => GStructuredProd (K1 i c) where-    gstructuredProd _ xs = structure (Proxy :: Proxy c) : xs--instance GStructuredProd U1 where-    gstructuredProd _ = id--instance (GStructuredProd f, GStructuredProd g) => GStructuredProd (f :*: g) where-    gstructuredProd _ xs-        = gstructuredProd (Proxy :: Proxy f)-        $ gstructuredProd (Proxy :: Proxy g) xs------------------------------------------------------------------------------------ instances----------------------------------------------------------------------------------instance Structured ()-instance Structured Bool-instance Structured Ordering--instance Structured Char    where structure = nominalStructure-instance Structured Int     where structure = nominalStructure-instance Structured Integer where structure = nominalStructure--instance Structured Data.Word.Word where structure = nominalStructure--instance Structured Int8  where structure = nominalStructure-instance Structured Int16 where structure = nominalStructure-instance Structured Int32 where structure = nominalStructure-instance Structured Int64 where structure = nominalStructure--instance Structured Word8  where structure = nominalStructure-instance Structured Word16 where structure = nominalStructure-instance Structured Word32 where structure = nominalStructure-instance Structured Word64 where structure = nominalStructure--instance Structured Float  where structure = nominalStructure-instance Structured Double where structure = nominalStructure--instance Structured a => Structured (Maybe a)-instance (Structured a, Structured b) => Structured (Either a b)-instance Structured a => Structured (Ratio a) where structure = containerStructure-instance Structured a => Structured [a] where structure = containerStructure-instance Structured a => Structured (NonEmpty a) where structure = containerStructure--instance (Structured a1, Structured a2) => Structured (a1, a2)-instance (Structured a1, Structured a2, Structured a3) => Structured (a1, a2, a3)-instance (Structured a1, Structured a2, Structured a3, Structured a4) => Structured (a1, a2, a3, a4)-instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5) => Structured (a1, a2, a3, a4, a5)-instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6) => Structured (a1, a2, a3, a4, a5, a6)-instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6, Structured a7) => Structured (a1, a2, a3, a4, a5, a6, a7)--instance Structured BS.ByteString where structure = nominalStructure-instance Structured LBS.ByteString where structure = nominalStructure--instance Structured T.Text where structure = nominalStructure-instance Structured LT.Text where structure = nominalStructure--instance (Structured k, Structured v) => Structured (Map.Map k v) where structure _ = Nominal (typeRep (Proxy :: Proxy (Map.Map k v))) 0 "Map" [ structure (Proxy :: Proxy k), structure (Proxy :: Proxy v) ]-instance (Structured k) => Structured (Set.Set k) where structure = containerStructure-instance (Structured v) => Structured (IM.IntMap v) where structure = containerStructure-instance Structured IS.IntSet where structure = nominalStructure-instance (Structured v) => Structured (Seq.Seq v) where structure = containerStructure--instance Structured Time.UTCTime         where structure = nominalStructure-instance Structured Time.DiffTime        where structure = nominalStructure-instance Structured Time.UniversalTime   where structure = nominalStructure-instance Structured Time.NominalDiffTime where structure = nominalStructure-instance Structured Time.Day             where structure = nominalStructure-instance Structured Time.TimeZone        where structure = nominalStructure-instance Structured Time.TimeOfDay       where structure = nominalStructure-instance Structured Time.LocalTime       where structure = nominalStructure---- Proxy isn't Typeable in base-4.8 / base---- #if __GLASGOW_HASKELL__ >= 800--- instance (Typeable k, Typeable (a :: k)) => Structured (Proxy a)--- #else--- instance (Typeable a) => Structured (Proxy a) where---     structure p = Structure (typeRep p) 0 "Proxy" [("Proxy",[])]--- #endif
src/Distribution/Utils/UnionFind.hs view
@@ -1,27 +1,27 @@ {-# LANGUAGE NondecreasingIndentation #-}+ -- | A simple mutable union-find data structure. -- -- It is used in a unification algorithm for backpack mix-in linking. -- -- This implementation is based off of the one in \"The Essence of ML Type -- Inference\". (N.B. the union-find package is also based off of this.)----module Distribution.Utils.UnionFind (-    Point,-    fresh,-    find,-    union,-    equivalent,-) where+module Distribution.Utils.UnionFind+  ( Point+  , fresh+  , find+  , union+  , equivalent+  ) where -import Data.STRef import Control.Monad import Control.Monad.ST+import Data.STRef  -- | A variable which can be unified; alternately, this can be thought -- of as an equivalence class with a distinguished representative. newtype Point s a = Point (STRef s (Link s a))-    deriving (Eq)+  deriving (Eq)  -- | Mutable write to a 'Point' writePoint :: Point s a -> Link s a -> ST s ()@@ -35,39 +35,41 @@ -- the representative element of an equivalence class, or a link to -- the 'Point' that actually stores the representative type. data Link s a-    -- NB: it is too bad we can't say STRef Int#; the weights remain boxed-    = Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a)-    | Link {-# UNPACK #-} !(Point s a)+  = -- NB: it is too bad we can't say STRef Int#; the weights remain boxed+    Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a)+  | Link {-# UNPACK #-} !(Point s a)  -- | Create a fresh equivalence class with one element. fresh :: a -> ST s (Point s a) fresh desc = do-    weight <- newSTRef 1-    descriptor <- newSTRef desc-    Point `fmap` newSTRef (Info weight descriptor)+  weight <- newSTRef 1+  descriptor <- newSTRef desc+  Point `fmap` newSTRef (Info weight descriptor)  -- | Flatten any chains of links, returning a 'Point' -- which points directly to the canonical representation. repr :: Point s a -> ST s (Point s a)-repr point = readPoint point >>= \r ->-  case r of-    Link point' -> do+repr point =+  readPoint point >>= \r ->+    case r of+      Link point' -> do         point'' <- repr point'         when (point'' /= point') $ do-            writePoint point =<< readPoint point'+          writePoint point =<< readPoint point'         return point''-    Info _ _ -> return point+      Info _ _ -> return point  -- | Return the canonical element of an equivalence -- class 'Point'. find :: Point s a -> ST s a find point =-    -- Optimize length 0 and 1 case at expense of-    -- general case-    readPoint point >>= \r ->-      case r of-        Info _ d_ref -> readSTRef d_ref-        Link point' -> readPoint point' >>= \r' ->+  -- Optimize length 0 and 1 case at expense of+  -- general case+  readPoint point >>= \r ->+    case r of+      Info _ d_ref -> readSTRef d_ref+      Link point' ->+        readPoint point' >>= \r' ->           case r' of             Info _ d_ref -> readSTRef d_ref             Link _ -> repr point >>= find@@ -76,26 +78,26 @@ -- a canonical element. Keeps the descriptor of point2. union :: Point s a -> Point s a -> ST s () union refpoint1 refpoint2 = do-    point1 <- repr refpoint1-    point2 <- repr refpoint2-    when (point1 /= point2) $ do+  point1 <- repr refpoint1+  point2 <- repr refpoint2+  when (point1 /= point2) $ do     l1 <- readPoint point1     l2 <- readPoint point2     case (l1, l2) of-        (Info wref1 dref1, Info wref2 dref2) -> do-            weight1 <- readSTRef wref1-            weight2 <- readSTRef wref2-            -- Should be able to optimize the == case separately-            if weight1 >= weight2-                then do-                    writePoint point2 (Link point1)-                    -- The weight calculation here seems a bit dodgy-                    writeSTRef wref1 (weight1 + weight2)-                    writeSTRef dref1 =<< readSTRef dref2-                else do-                    writePoint point1 (Link point2)-                    writeSTRef wref2 (weight1 + weight2)-        _ -> error "UnionFind.union: repr invariant broken"+      (Info wref1 dref1, Info wref2 dref2) -> do+        weight1 <- readSTRef wref1+        weight2 <- readSTRef wref2+        -- Should be able to optimize the == case separately+        if weight1 >= weight2+          then do+            writePoint point2 (Link point1)+            -- The weight calculation here seems a bit dodgy+            writeSTRef wref1 (weight1 + weight2)+            writeSTRef dref1 =<< readSTRef dref2+          else do+            writePoint point1 (Link point2)+            writeSTRef wref2 (weight1 + weight2)+      _ -> error "UnionFind.union: repr invariant broken"  -- | Test if two points are in the same equivalence class. equivalent :: Point s a -> Point s a -> ST s Bool
src/Distribution/Verbosity.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}  -----------------------------------------------------------------------------++-- Verbosity for Cabal functions.+ -- | -- Module      :  Distribution.Verbosity -- Copyright   :  Ian Lynagh 2007@@ -21,113 +23,131 @@ -- settings (e.g., so that you can trace only particular things you -- are interested in.)  It's important to note that the instances -- for 'Verbosity' assume that this does not exist.---- Verbosity for Cabal functions.+module Distribution.Verbosity+  ( -- * Verbosity+    Verbosity+  , silent+  , normal+  , verbose+  , deafening+  , moreVerbose+  , lessVerbose+  , isVerboseQuiet+  , intToVerbosity+  , flagToVerbosity+  , showForCabal+  , showForGHC+  , verboseNoFlags+  , verboseHasFlags+  , modifyVerbosity -module Distribution.Verbosity (-  -- * Verbosity-  Verbosity,-  silent, normal, verbose, deafening,-  moreVerbose, lessVerbose, isVerboseQuiet,-  intToVerbosity, flagToVerbosity,-  showForCabal, showForGHC,-  verboseNoFlags, verboseHasFlags,-  modifyVerbosity,+    -- * Call stacks+  , verboseCallSite+  , verboseCallStack+  , isVerboseCallSite+  , isVerboseCallStack -  -- * Call stacks-  verboseCallSite, verboseCallStack,-  isVerboseCallSite, isVerboseCallStack,+    -- * Output markets+  , verboseMarkOutput+  , isVerboseMarkOutput+  , verboseUnmarkOutput -  -- * Output markets-  verboseMarkOutput, isVerboseMarkOutput,-  verboseUnmarkOutput,+    -- * Line wrapping+  , verboseNoWrap+  , isVerboseNoWrap -  -- * line-wrapping-  verboseNoWrap, isVerboseNoWrap,+    -- * Time stamps+  , verboseTimestamp+  , isVerboseTimestamp+  , verboseNoTimestamp -  -- * timestamps-  verboseTimestamp, isVerboseTimestamp,-  verboseNoTimestamp,+    -- * Stderr+  , verboseStderr+  , isVerboseStderr+  , verboseNoStderr -  -- * Stderr-  verboseStderr, isVerboseStderr,-  verboseNoStderr,+    -- * No warnings+  , verboseNoWarn+  , isVerboseNoWarn   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import Distribution.ReadE  import Data.List (elemIndex) import Distribution.Parsec import Distribution.Pretty-import Distribution.Verbosity.Internal import Distribution.Utils.Generic (isAsciiAlpha)+import Distribution.Verbosity.Internal  import qualified Data.Set as Set import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as PP -data Verbosity = Verbosity {-    vLevel :: VerbosityLevel,-    vFlags :: Set VerbosityFlag,-    vQuiet :: Bool-  } deriving (Generic, Show, Read, Typeable)+data Verbosity = Verbosity+  { vLevel :: VerbosityLevel+  , vFlags :: Set VerbosityFlag+  , vQuiet :: Bool+  }+  deriving (Generic, Show, Read)  mkVerbosity :: VerbosityLevel -> Verbosity-mkVerbosity l = Verbosity { vLevel = l, vFlags = Set.empty, vQuiet = False }+mkVerbosity l = Verbosity{vLevel = l, vFlags = Set.empty, vQuiet = False}  instance Eq Verbosity where-    x == y = vLevel x == vLevel y+  x == y = vLevel x == vLevel y  instance Ord Verbosity where-    compare x y = compare (vLevel x) (vLevel y)+  compare x y = compare (vLevel x) (vLevel y)  instance Enum Verbosity where-    toEnum = mkVerbosity . toEnum-    fromEnum = fromEnum . vLevel+  toEnum = mkVerbosity . toEnum+  fromEnum = fromEnum . vLevel  instance Bounded Verbosity where-    minBound = mkVerbosity minBound-    maxBound = mkVerbosity maxBound+  minBound = mkVerbosity minBound+  maxBound = mkVerbosity maxBound  instance Binary Verbosity instance Structured Verbosity --- We shouldn't print /anything/ unless an error occurs in silent mode+-- | In 'silent' mode, we should not print /anything/ unless an error occurs. silent :: Verbosity silent = mkVerbosity Silent --- Print stuff we want to see by default+-- | Print stuff we want to see by default. normal :: Verbosity normal = mkVerbosity Normal --- Be more verbose about what's going on+-- | Be more verbose about what's going on. verbose :: Verbosity verbose = mkVerbosity Verbose --- Not only are we verbose ourselves (perhaps even noisier than when--- being "verbose"), but we tell everything we run to be verbose too+-- | 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 +-- | Increase verbosity level, but stay 'silent' if we are. moreVerbose :: Verbosity -> Verbosity moreVerbose v =-    case vLevel v of-        Silent    -> v -- silent should stay silent-        Normal    -> v { vLevel = Verbose }-        Verbose   -> v { vLevel = Deafening }-        Deafening -> v+  case vLevel v of+    Silent -> v -- silent should stay silent+    Normal -> v{vLevel = Verbose}+    Verbose -> v{vLevel = Deafening}+    Deafening -> v +-- | Decrease verbosity level, but stay 'deafening' if we are. lessVerbose :: Verbosity -> Verbosity lessVerbose v =-    verboseQuiet $+  verboseQuiet $     case vLevel v of-        Deafening -> v -- deafening stays deafening-        Verbose   -> v { vLevel = Normal }-        Normal    -> v { vLevel = Silent }-        Silent    -> v+      Deafening -> v -- deafening stays deafening+      Verbose -> v{vLevel = Normal}+      Normal -> v{vLevel = Silent}+      Silent -> v  -- | Combinator for transforming verbosity level while retaining the -- original hidden state.@@ -141,8 +161,9 @@ -- -- @since 2.0.1.0 modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity-modifyVerbosity f v = v { vLevel = vLevel (f v) }+modifyVerbosity f v = v{vLevel = vLevel (f v)} +-- | Numeric verbosity level @0..3@: @0@ is 'silent', @3@ is 'deafening'. intToVerbosity :: Int -> Maybe Verbosity intToVerbosity 0 = Just (mkVerbosity Silent) intToVerbosity 1 = Just (mkVerbosity Normal)@@ -171,79 +192,82 @@ -- Right (Verbosity {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False}) -- -- /Note:/ this parser will eat trailing spaces.--- instance Parsec Verbosity where-    parsec = parsecVerbosity+  parsec = parsecVerbosity  instance Pretty Verbosity where-    pretty = PP.text . showForCabal+  pretty = PP.text . showForCabal  parsecVerbosity :: CabalParsing m => m Verbosity parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity   where     parseIntVerbosity = do-        i <- P.integral-        case intToVerbosity i of-            Just v  -> return v-            Nothing -> P.unexpected $ "Bad integral verbosity: " ++ show i ++ ". Valid values are 0..3"+      i <- P.integral+      case intToVerbosity i of+        Just v -> return v+        Nothing -> P.unexpected $ "Bad integral verbosity: " ++ show i ++ ". Valid values are 0..3"      parseStringVerbosity = do-        level <- parseVerbosityLevel-        _ <- P.spaces-        flags <- many (parseFlag <* P.spaces)-        return $ foldl' (flip ($)) (mkVerbosity level) flags+      level <- parseVerbosityLevel+      _ <- P.spaces+      flags <- many (parseFlag <* P.spaces)+      return $ foldl' (flip ($)) (mkVerbosity level) flags      parseVerbosityLevel = do-        token <- P.munch1 isAsciiAlpha-        case token of-            "silent"    -> return Silent-            "normal"    -> return Normal-            "verbose"   -> return Verbose-            "debug"     -> return Deafening-            "deafening" -> return Deafening-            _           -> P.unexpected $ "Bad verbosity level: " ++ token+      token <- P.munch1 isAsciiAlpha+      case token of+        "silent" -> return Silent+        "normal" -> return Normal+        "verbose" -> return Verbose+        "debug" -> return Deafening+        "deafening" -> return Deafening+        _ -> P.unexpected $ "Bad verbosity level: " ++ token     parseFlag = do-        _ <- P.char '+'-        token <- P.munch1 isAsciiAlpha-        case token of-            "callsite"   -> return verboseCallSite-            "callstack"  -> return verboseCallStack-            "nowrap"     -> return verboseNoWrap-            "markoutput" -> return verboseMarkOutput-            "timestamp"  -> return verboseTimestamp-            "stderr"     -> return verboseStderr-            "stdout"     -> return verboseNoStderr-            _            -> P.unexpected $ "Bad verbosity flag: " ++ token+      _ <- P.char '+'+      token <- P.munch1 isAsciiAlpha+      case token of+        "callsite" -> return verboseCallSite+        "callstack" -> return verboseCallStack+        "nowrap" -> return verboseNoWrap+        "markoutput" -> return verboseMarkOutput+        "timestamp" -> return verboseTimestamp+        "stderr" -> return verboseStderr+        "stdout" -> return verboseNoStderr+        "nowarn" -> return verboseNoWarn+        _ -> P.unexpected $ "Bad verbosity flag: " ++ token  flagToVerbosity :: ReadE Verbosity flagToVerbosity = parsecToReadE id parsecVerbosity  showForCabal :: Verbosity -> String showForCabal v-    | Set.null (vFlags v)-    = maybe (error "unknown verbosity") show $-        elemIndex v [silent,normal,verbose,deafening]-    | otherwise-    = unwords-        $ showLevel (vLevel v)-        : concatMap showFlag (Set.toList (vFlags v))+  | Set.null (vFlags v) =+      maybe (error "unknown verbosity") show $+        elemIndex v [silent, normal, verbose, deafening]+  | otherwise =+      unwords $+        showLevel (vLevel v)+          : concatMap showFlag (Set.toList (vFlags v))   where-    showLevel Silent    = "silent"-    showLevel Normal    = "normal"-    showLevel Verbose   = "verbose"+    showLevel Silent = "silent"+    showLevel Normal = "normal"+    showLevel Verbose = "verbose"     showLevel Deafening = "debug" -    showFlag VCallSite   = ["+callsite"]-    showFlag VCallStack  = ["+callstack"]-    showFlag VNoWrap     = ["+nowrap"]+    showFlag VCallSite = ["+callsite"]+    showFlag VCallStack = ["+callstack"]+    showFlag VNoWrap = ["+nowrap"]     showFlag VMarkOutput = ["+markoutput"]-    showFlag VTimestamp  = ["+timestamp"]-    showFlag VStderr     = ["+stderr"]+    showFlag VTimestamp = ["+timestamp"]+    showFlag VStderr = ["+stderr"]+    showFlag VNoWarn = ["+nowarn"]  showForGHC :: Verbosity -> String-showForGHC   v = maybe (error "unknown verbosity") show $-    elemIndex v [silent,normal,__,verbose,deafening]-        where __ = silent -- this will be always ignored by elemIndex+showForGHC v =+  maybe (error "unknown verbosity") show $+    elemIndex v [silent, normal, __, verbose, deafening]+  where+    __ = silent -- this will be always ignored by elemIndex  -- | Turn on verbose call-site printing when we log. verboseCallSite :: Verbosity -> Verbosity@@ -266,9 +290,9 @@ verboseNoWrap :: Verbosity -> Verbosity verboseNoWrap = verboseFlag VNoWrap --- | Mark the verbosity as quiet+-- | Mark the verbosity as quiet. verboseQuiet :: Verbosity -> Verbosity-verboseQuiet v = v { vQuiet = True }+verboseQuiet v = v{vQuiet = True}  -- | Turn on timestamps for log messages. verboseTimestamp :: Verbosity -> Verbosity@@ -278,29 +302,33 @@ verboseNoTimestamp :: Verbosity -> Verbosity verboseNoTimestamp = verboseNoFlag VTimestamp --- | Turn on timestamps for log messages.+-- | Switch logging to 'stderr'. -- -- @since 3.4.0.0 verboseStderr :: Verbosity -> Verbosity verboseStderr = verboseFlag VStderr --- | Turn off timestamps for log messages.+-- | Switch logging to 'stdout'. -- -- @since 3.4.0.0 verboseNoStderr :: Verbosity -> Verbosity verboseNoStderr = verboseNoFlag VStderr --- | Helper function for flag enabling functions+-- | Turn off warnings for log messages.+verboseNoWarn :: Verbosity -> Verbosity+verboseNoWarn = verboseFlag VNoWarn++-- | Helper function for flag enabling functions. verboseFlag :: VerbosityFlag -> (Verbosity -> Verbosity)-verboseFlag flag v = v { vFlags = Set.insert flag (vFlags v) }+verboseFlag flag v = v{vFlags = Set.insert flag (vFlags v)} --- | Helper function for flag disabling functions+-- | Helper function for flag disabling functions. verboseNoFlag :: VerbosityFlag -> (Verbosity -> Verbosity)-verboseNoFlag flag v = v { vFlags = Set.delete flag (vFlags v) }+verboseNoFlag flag v = v{vFlags = Set.delete flag (vFlags v)} --- | Turn off all flags+-- | Turn off all flags. verboseNoFlags :: Verbosity -> Verbosity-verboseNoFlags v = v { vFlags = Set.empty }+verboseNoFlags v = v{vFlags = Set.empty}  verboseHasFlags :: Verbosity -> Bool verboseHasFlags = not . Set.null . vFlags@@ -321,7 +349,7 @@ isVerboseNoWrap :: Verbosity -> Bool isVerboseNoWrap = isVerboseFlag VNoWrap --- | Test if we had called 'lessVerbose' on the verbosity+-- | Test if we had called 'lessVerbose' on the verbosity. isVerboseQuiet :: Verbosity -> Bool isVerboseQuiet = vQuiet @@ -329,11 +357,15 @@ isVerboseTimestamp :: Verbosity -> Bool isVerboseTimestamp = isVerboseFlag VTimestamp --- | Test if we should output to stderr when we log.+-- | Test if we should output to 'stderr' when we log. -- -- @since 3.4.0.0 isVerboseStderr :: Verbosity -> Bool isVerboseStderr = isVerboseFlag VStderr++-- | Test if we should output warnings when we log.+isVerboseNoWarn :: Verbosity -> Bool+isVerboseNoWarn = isVerboseFlag VNoWarn  -- | Helper function for flag testing functions. isVerboseFlag :: VerbosityFlag -> Verbosity -> Bool
src/Distribution/Verbosity/Internal.hs view
@@ -1,27 +1,29 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+ module Distribution.Verbosity.Internal-  ( VerbosityLevel(..)-  , VerbosityFlag(..)+  ( VerbosityLevel (..)+  , VerbosityFlag (..)   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  data VerbosityLevel = Silent | Normal | Verbose | Deafening-    deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable)+  deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)  instance Binary VerbosityLevel instance Structured VerbosityLevel  data VerbosityFlag-    = VCallStack-    | VCallSite-    | VNoWrap-    | VMarkOutput-    | VTimestamp-    | VStderr -- ^ @since 3.4.0.0-    deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable)+  = VCallStack+  | VCallSite+  | VNoWrap+  | VMarkOutput+  | VTimestamp+  | -- | @since 3.4.0.0+    VStderr+  | VNoWarn+  deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)  instance Binary VerbosityFlag instance Structured VerbosityFlag
− src/Distribution/Version.hs 
@@ -1,185 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Version--- Copyright   :  Isaac Jones, Simon Marlow 2003-2004---                Duncan Coutts 2008--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Exports the 'Version' type along with a parser and pretty printer. A version--- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data--- types. Version ranges are like @\">= 1.2 && < 2\"@.--module Distribution.Version (-  -- * Package versions-  Version,-  version0,-  mkVersion,-  mkVersion',-  versionNumbers,-  nullVersion,-  alterVersion,--  -- * Version ranges-  VersionRange,--  -- ** Constructing-  anyVersion, noVersion,-  thisVersion, notThisVersion,-  laterVersion, earlierVersion,-  orLaterVersion, orEarlierVersion,-  unionVersionRanges, intersectVersionRanges,-  withinVersion,-  majorBoundVersion,--  -- ** Inspection-  withinRange,-  isAnyVersion,-  isNoVersion,-  isSpecificVersion,-  simplifyVersionRange,-  foldVersionRange,-  normaliseVersionRange,-  stripParensVersionRange,-  hasUpperBound,-  hasLowerBound,--  -- ** Cata & ana-  VersionRangeF (..),-  cataVersionRange,-  anaVersionRange,-  hyloVersionRange,-  projectVersionRange,-  embedVersionRange,--  -- ** Utilities-  wildcardUpperBound,-  majorUpperBound,--  -- ** Modification-  removeUpperBound,-  removeLowerBound,-  transformCaret,-  transformCaretUpper,-  transformCaretLower,--  -- * Version intervals view-  asVersionIntervals,-  VersionInterval(..),-  LowerBound(..),-  UpperBound(..),-  Bound(..),--  -- ** 'VersionIntervals' abstract type-  -- | The 'VersionIntervals' type and the accompanying functions are exposed-  -- primarily for completeness and testing purposes. In practice-  -- 'asVersionIntervals' is the main function to use to-  -- view a 'VersionRange' as a bunch of 'VersionInterval's.-  ---  VersionIntervals,-  toVersionIntervals,-  fromVersionIntervals,-  unVersionIntervals,-- ) where--import Distribution.Types.Version-import Distribution.Types.VersionRange-import Distribution.Types.VersionInterval------------------------------------------------------------------------------------ Utilities on VersionRange requiring VersionInterval------------------------------------------------------------------------------------ | This is the converse of 'isAnyVersion'. It check if the version range is--- empty, if there is no possible version that satisfies the version range.------ For example this is @True@ (for all @v@):------ > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v)----isNoVersion :: VersionRange -> Bool-isNoVersion vr = case asVersionIntervals vr of-  [] -> True-  _  -> False---- | Is this version range in fact just a specific version?------ For example the version range @\">= 3 && <= 3\"@ contains only the version--- @3@.----isSpecificVersion :: VersionRange -> Maybe Version-isSpecificVersion vr = case asVersionIntervals vr of-  [VersionInterval (LowerBound v  InclusiveBound) (UpperBound v' InclusiveBound)]-    | v == v' -> Just v-  _           -> Nothing------------------------------------------------------------------------------------ Transformations------------------------------------------------------------------------------------ | Simplify a 'VersionRange' expression. For non-empty version ranges--- this produces a canonical form. Empty or inconsistent version ranges--- are left as-is because that provides more information.------ If you need a canonical form use--- @fromVersionIntervals . toVersionIntervals@------ It satisfies the following properties:------ > withinRange v (simplifyVersionRange r) = withinRange v r------ >     withinRange v r = withinRange v r'--- > ==> simplifyVersionRange r = simplifyVersionRange r'--- >  || isNoVersion r--- >  || isNoVersion r'----simplifyVersionRange :: VersionRange -> VersionRange-simplifyVersionRange vr-    -- If the version range is inconsistent then we just return the-    -- original since that has more information than ">1 && < 1", which-    -- is the canonical inconsistent version range.-    | null (unVersionIntervals vi) = vr-    | otherwise                    = fromVersionIntervals vi-  where-    vi = toVersionIntervals vr---- | Given a version range, remove the highest upper bound. Example: @(>= 1 && <--- 3) || (>= 4 && < 5)@ is converted to @(>= 1 && < 3) || (>= 4)@.-removeUpperBound :: VersionRange -> VersionRange-removeUpperBound = fromVersionIntervals . relaxLastInterval . toVersionIntervals---- | Given a version range, remove the lowest lower bound.--- Example: @(>= 1 && < 3) || (>= 4 && < 5)@ is converted to--- @(>= 0 && < 3) || (>= 4 && < 5)@.-removeLowerBound :: VersionRange -> VersionRange-removeLowerBound = fromVersionIntervals . relaxHeadInterval . toVersionIntervals---- | Rewrite @^>= x.y.z@ into @>= x.y.z && < x.(y+1)@------ @since 3.6.0.0----transformCaret :: VersionRange -> VersionRange-transformCaret = hyloVersionRange embed projectVersionRange where-    embed (MajorBoundVersionF v) = orLaterVersion v `intersectVersionRanges` earlierVersion (majorUpperBound v)-    embed vr                     = embedVersionRange vr---- | Rewrite @^>= x.y.z@ into @>= x.y.z@------ @since 3.6.0.0----transformCaretUpper :: VersionRange -> VersionRange-transformCaretUpper = hyloVersionRange embed projectVersionRange where-    embed (MajorBoundVersionF v) = orLaterVersion v-    embed vr                     = embedVersionRange vr---- | Rewrite @^>= x.y.z@ into @<x.(y+1)@------ @since 3.6.0.0----transformCaretLower :: VersionRange -> VersionRange-transformCaretLower = hyloVersionRange embed projectVersionRange where-    embed (MajorBoundVersionF v) = earlierVersion (majorUpperBound v)-    embed vr                     = embedVersionRange vr
src/Distribution/ZinzaPrelude.hs view
@@ -1,40 +1,41 @@ -- | A small prelude used in @zinza@ generated -- template modules.-module Distribution.ZinzaPrelude (-    Writer,-    execWriter,-    tell,+module Distribution.ZinzaPrelude+  ( Writer+  , execWriter+  , tell+     -- * Re-exports-    forM_,-    Generic,-    PackageName,-    Version,-    prettyShow-    ) where+  , forM_+  , Generic+  , PackageName+  , Version+  , prettyShow+  ) where  import Distribution.Compat.Prelude import Prelude () -import Control.Monad                  (forM_)-import Distribution.Pretty            (prettyShow)+import Control.Monad (forM_)+import Distribution.Pretty (prettyShow) import Distribution.Types.PackageName (PackageName)-import Distribution.Types.Version     (Version)+import Distribution.Types.Version (Version) -newtype Writer a = W { unW :: ShowS -> (ShowS, a) }+newtype Writer a = W {unW :: ShowS -> (ShowS, a)}  instance Functor Writer where-    fmap = liftM+  fmap = liftM  instance Applicative Writer where-    pure x = W $ \ss -> (ss, x)-    (<*>) = ap+  pure x = W $ \ss -> (ss, x)+  (<*>) = ap  instance Monad Writer where-    return = pure-    m >>= k = W $ \s1 ->-        let (s2, x) = unW m s1-        in unW (k x) s2-    {-# INLINE (>>=) #-}+  return = pure+  m >>= k = W $ \s1 ->+    let (s2, x) = unW m s1+     in unW (k x) s2+  {-# INLINE (>>=) #-}  execWriter :: Writer a -> String execWriter w = fst (unW w id) ""
− src/Language/Haskell/Extension.hs 
@@ -1,933 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}---------------------------------------------------------------------------------- |--- Module      :  Language.Haskell.Extension--- Copyright   :  Isaac Jones 2003-2004--- License     :  BSD3------ Maintainer  :  libraries@haskell.org--- Portability :  portable------ Haskell language dialects and extensions--module Language.Haskell.Extension (-        Language(..),-        knownLanguages,-        classifyLanguage,--        Extension(..),-        KnownExtension(..),-        deprecatedExtensions,-        classifyExtension,-  ) where--import qualified Prelude (head)-import Distribution.Compat.Prelude--import Data.Array (Array, accumArray, bounds, Ix(inRange), (!))--import Distribution.Parsec-import Distribution.Pretty--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp---- --------------------------------------------------------------- * Language--- ---------------------------------------------------------------- | This represents a Haskell language dialect.------ Language 'Extension's are interpreted relative to one of these base--- languages.----data Language =--  -- | The Haskell 98 language as defined by the Haskell 98 report.-  -- <http://haskell.org/onlinereport/>-     Haskell98--  -- | The Haskell 2010 language as defined by the Haskell 2010 report.-  -- <http://www.haskell.org/onlinereport/haskell2010>-  | Haskell2010--  -- | The GHC2021 collection of language extensions.-  -- <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0380-ghc2021.rst>-  | GHC2021--  -- | An unknown language, identified by its name.-  | UnknownLanguage String-  deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary Language-instance Structured Language--instance NFData Language where rnf = genericRnf---- | List of known (supported) languages for GHC-knownLanguages :: [Language]-knownLanguages = [Haskell98, Haskell2010, GHC2021]--instance Pretty Language where-  pretty (UnknownLanguage other) = Disp.text other-  pretty other                   = Disp.text (show other)--instance Parsec Language where-  parsec = classifyLanguage <$> P.munch1 isAlphaNum--classifyLanguage :: String -> Language-classifyLanguage = \str -> case lookup str langTable of-    Just lang -> lang-    Nothing   -> UnknownLanguage str-  where-    langTable = [ (show lang, lang)-                | lang <- knownLanguages ]---- --------------------------------------------------------------- * Extension--- ---------------------------------------------------------------- Note: if you add a new 'KnownExtension':------ * also add it to the Distribution.Simple.X.languageExtensions lists---   (where X is each compiler: GHC, UHC, HaskellSuite)------ | This represents language extensions beyond a base 'Language' definition--- (such as 'Haskell98') that are supported by some implementations, usually--- in some special mode.------ Where applicable, references are given to an implementation's--- official documentation.--data Extension =-  -- | Enable a known extension-    EnableExtension KnownExtension--  -- | Disable a known extension-  | DisableExtension KnownExtension--  -- | An unknown extension, identified by the name of its @LANGUAGE@-  -- pragma.-  | UnknownExtension String--  deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)--instance Binary Extension-instance Structured Extension--instance NFData Extension where rnf = genericRnf--data KnownExtension =--  -- | Allow overlapping class instances, provided there is a unique-  -- most specific instance for each use.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XOverlappingInstances>-    OverlappingInstances--  -- | Ignore structural rules guaranteeing the termination of class-  -- instance resolution.  Termination is guaranteed by a fixed-depth-  -- recursion stack, and compilation may fail if this depth is-  -- exceeded.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XUndecidableInstances>-  | UndecidableInstances--  -- | Implies 'OverlappingInstances'.  Allow the implementation to-  -- choose an instance even when it is possible that further-  -- instantiation of types will lead to a more specific instance-  -- being applicable.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XIncoherentInstances>-  | IncoherentInstances--  -- | /(deprecated)/ Deprecated in favour of 'RecursiveDo'.-  ---  -- Old description: Allow recursive bindings in @do@ blocks, using-  -- the @rec@ keyword. See also 'RecursiveDo'.-  | DoRec--  -- | Allow recursive bindings in @do@ blocks, using the @rec@-  -- keyword, or @mdo@, a variant of @do@.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XRecursiveDo>-  | RecursiveDo--  -- | Provide syntax for writing list comprehensions which iterate-  -- over several lists together, like the 'zipWith' family of-  -- functions.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XParallelListComp>-  | ParallelListComp--  -- | Allow multiple parameters in a type class.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XMultiParamTypeClasses>-  | MultiParamTypeClasses--  -- | Enable the dreaded monomorphism restriction.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XNoMonomorphismRestriction>-  | MonomorphismRestriction--  -- | Allow a specification attached to a multi-parameter type class-  -- which indicates that some parameters are entirely determined by-  -- others. The implementation will check that this property holds-  -- for the declared instances, and will use this property to reduce-  -- ambiguity in instance resolution.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XFunctionalDependencies>-  | FunctionalDependencies--  -- | /(deprecated)/ A synonym for 'RankNTypes'.-  ---  -- Old description: Like 'RankNTypes' but does not allow a-  -- higher-rank type to itself appear on the left of a function-  -- arrow.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XRank2Types>-  | Rank2Types--  -- | Allow a universally-quantified type to occur on the left of a-  -- function arrow.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XRankNTypes>-  | RankNTypes--  -- | /(deprecated)/ A synonym for 'RankNTypes'.-  ---  -- Old description: Allow data constructors to have polymorphic-  -- arguments.  Unlike 'RankNTypes', does not allow this for ordinary-  -- functions.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#arbitrary-rank-polymorphism>-  | PolymorphicComponents--  -- | Allow existentially-quantified data constructors.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XExistentialQuantification>-  | ExistentialQuantification--  -- | Cause a type variable in a signature, which has an explicit-  -- @forall@ quantifier, to scope over the definition of the-  -- accompanying value declaration.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XScopedTypeVariables>-  | ScopedTypeVariables--  -- | Deprecated, use 'ScopedTypeVariables' instead.-  | PatternSignatures--  -- | Enable implicit function parameters with dynamic scope.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XImplicitParams>-  | ImplicitParams--  -- | Relax some restrictions on the form of the context of a type-  -- signature.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XFlexibleContexts>-  | FlexibleContexts--  -- | Relax some restrictions on the form of the context of an-  -- instance declaration.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XFlexibleInstances>-  | FlexibleInstances--  -- | Allow data type declarations with no constructors.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XEmptyDataDecls>-  | EmptyDataDecls--  -- | Run the C preprocessor on Haskell source code.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#language-pragma>-  | CPP--  -- | Allow an explicit kind signature giving the kind of types over-  -- which a type variable ranges.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XKindSignatures>-  | KindSignatures--  -- | Enable a form of pattern which forces evaluation before an-  -- attempted match, and a form of strict @let@/@where@ binding.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XBangPatterns>-  | BangPatterns--  -- | Allow type synonyms in instance heads.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XTypeSynonymInstances>-  | TypeSynonymInstances--  -- | Enable Template Haskell, a system for compile-time-  -- metaprogramming.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XTemplateHaskell>-  | TemplateHaskell--  -- | Enable the Foreign Function Interface.  In GHC, implements the-  -- standard Haskell 98 Foreign Function Interface Addendum, plus-  -- some GHC-specific extensions.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#language-pragma>-  | ForeignFunctionInterface--  -- | Enable arrow notation.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XArrows>-  | Arrows--  -- | /(deprecated)/ Enable generic type classes, with default instances defined in-  -- terms of the algebraic structure of a type.-  ---  -- * <https://haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#generic-classes>-  | Generics--  -- | Enable the implicit importing of the module "Prelude".  When-  -- disabled, when desugaring certain built-in syntax into ordinary-  -- identifiers, use whatever is in scope rather than the "Prelude"-  -- -- version.-  ---  -- * <https://haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#rebindable-syntax-and-the-implicit-prelude-import>-  | ImplicitPrelude--  -- | Enable syntax for implicitly binding local names corresponding-  -- to the field names of a record.  Puns bind specific names, unlike-  -- 'RecordWildCards'.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XNamedFieldPuns>-  | NamedFieldPuns--  -- | Enable a form of guard which matches a pattern and binds-  -- variables.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XPatternGuards>-  | PatternGuards--  -- | Allow a type declared with @newtype@ to use @deriving@ for any-  -- class with an instance for the underlying type.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XGeneralizedNewtypeDeriving>-  | GeneralizedNewtypeDeriving--  -- Synonym for GeneralizedNewtypeDeriving added in GHC 8.6.1.-  | GeneralisedNewtypeDeriving--  -- | Enable the \"Trex\" extensible records system.-  ---  -- * <http://haskell.org/hugs/pages/users_guide/hugs-only.html#TREX>-  | ExtensibleRecords--  -- | Enable type synonyms which are transparent in some definitions-  -- and opaque elsewhere, as a way of implementing abstract-  -- datatypes.-  ---  -- * <http://haskell.org/hugs/pages/users_guide/restricted-synonyms.html>-  | RestrictedTypeSynonyms--  -- | Enable an alternate syntax for string literals,-  -- with string templating.-  ---  -- * <http://haskell.org/hugs/pages/users_guide/here-documents.html>-  | HereDocuments--  -- | Allow the character @#@ as a postfix modifier on identifiers.-  -- Also enables literal syntax for unboxed values.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XMagicHash>-  | MagicHash--  -- | Allow data types and type synonyms which are indexed by types,-  -- i.e. ad-hoc polymorphism for types.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XTypeFamilies>-  | TypeFamilies--  -- | Allow a standalone declaration which invokes the type class-  -- @deriving@ mechanism.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XStandaloneDeriving>-  | StandaloneDeriving--  -- | Allow certain Unicode characters to stand for certain ASCII-  -- character sequences, e.g. keywords and punctuation.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XUnicodeSyntax>-  | UnicodeSyntax--  -- | Allow the use of unboxed types as foreign types, e.g. in-  -- @foreign import@ and @foreign export@.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#language-options>-  | UnliftedFFITypes--  -- | Enable interruptible FFI.-  ---  -- * <https://haskell.org/ghc/docs/latest/html/users_guide/ffi-chap.html#interruptible-foreign-calls>-  | InterruptibleFFI--  -- | Allow use of CAPI FFI calling convention (@foreign import capi@).-  ---  -- * <https://haskell.org/ghc/docs/latest/html/users_guide/ffi-chap.html#the-capi-calling-convention>-  | CApiFFI--  -- | Defer validity checking of types until after expanding type-  -- synonyms, relaxing the constraints on how synonyms may be used.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XLiberalTypeSynonyms>-  | LiberalTypeSynonyms--  -- | Allow the name of a type constructor, type class, or type-  -- variable to be an infix operator.-  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XTypeOperators>-  | TypeOperators--  -- | Enable syntax for implicitly binding local names corresponding-  -- to the field names of a record.  A wildcard binds all unmentioned-  -- names, unlike 'NamedFieldPuns'.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XRecordWildCards>-  | RecordWildCards--  -- | Deprecated, use 'NamedFieldPuns' instead.-  | RecordPuns--  -- | Allow a record field name to be disambiguated by the type of-  -- the record it's in.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XDisambiguateRecordFields>-  | DisambiguateRecordFields--  -- | Enable traditional record syntax (as supported by Haskell 98)-  ---  -- * <https://haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#traditional-record-syntax>-  | TraditionalRecordSyntax--  -- | Enable overloading of string literals using a type class, much-  -- like integer literals.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XOverloadedStrings>-  | OverloadedStrings--  -- | Enable generalized algebraic data types, in which type-  -- variables may be instantiated on a per-constructor basis. Implies-  -- 'GADTSyntax'.-  ---  -- * <https://haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#generalised-algebraic-data-types-gadts>-  | GADTs--  -- | Enable GADT syntax for declaring ordinary algebraic datatypes.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XGADTSyntax>-  | GADTSyntax--  -- | /(deprecated)/ Has no effect.-  ---  -- Old description: Make pattern bindings monomorphic.-  ---  -- * <https://downloads.haskell.org/~ghc/7.6.3/docs/html/users_guide/monomorphism.html>-  | MonoPatBinds--  -- | Relax the requirements on mutually-recursive polymorphic-  -- functions.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XRelaxedPolyRec>-  | RelaxedPolyRec--  -- | Allow default instantiation of polymorphic types in more-  -- situations.-  ---  -- * <http://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci.html#type-defaulting-in-ghci>-  | ExtendedDefaultRules--  -- | Enable unboxed tuples.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XUnboxedTuples>-  | UnboxedTuples--  -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and-  -- 'Data.Generics.Data'.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XDeriveDataTypeable>-  | DeriveDataTypeable--  -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XDeriveGeneric>-  | DeriveGeneric--  -- | Enable support for default signatures.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XDefaultSignatures>-  | DefaultSignatures--  -- | Allow type signatures to be specified in instance declarations.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XInstanceSigs>-  | InstanceSigs--  -- | Allow a class method's type to place additional constraints on-  -- a class type variable.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XConstrainedClassMethods>-  | ConstrainedClassMethods--  -- | Allow imports to be qualified by the package name the module is-  -- intended to be imported from, e.g.-  ---  -- > import "network" Network.Socket-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XPackageImports>-  | PackageImports--  -- | /(deprecated)/ Allow a type variable to be instantiated at a-  -- polymorphic type.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XImpredicativeTypes>-  | ImpredicativeTypes--  -- | /(deprecated)/ Change the syntax for qualified infix operators.-  ---  -- * <http://www.haskell.org/ghc/docs/6.12.3/html/users_guide/syntax-extns.html#new-qualified-operators>-  | NewQualifiedOperators--  -- | Relax the interpretation of left operator sections to allow-  -- unary postfix operators.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XPostfixOperators>-  | PostfixOperators--  -- | Enable quasi-quotation, a mechanism for defining new concrete-  -- syntax for expressions and patterns.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XQuasiQuotes>-  | QuasiQuotes--  -- | Enable generalized list comprehensions, supporting operations-  -- such as sorting and grouping.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XTransformListComp>-  | TransformListComp--  -- | Enable monad comprehensions, which generalise the list-  -- comprehension syntax to work for any monad.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XMonadComprehensions>-  | MonadComprehensions--  -- | Enable view patterns, which match a value by applying a-  -- function and matching on the result.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XViewPatterns>-  | ViewPatterns--  -- | Allow concrete XML syntax to be used in expressions and patterns,-  -- as per the Haskell Server Pages extension language:-  -- <http://www.haskell.org/haskellwiki/HSP>. The ideas behind it are-  -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\"-  -- by Niklas Broberg, from Haskell Workshop '05.-  | XmlSyntax--  -- | Allow regular pattern matching over lists, as discussed in the-  -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre-  -- and Josef Svenningsson, from ICFP '04.-  | RegularPatterns--  -- | Enable the use of tuple sections, e.g. @(, True)@ desugars into-  -- @\x -> (x, True)@.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XTupleSections>-  | TupleSections--  -- | Allow GHC primops, written in C--, to be imported into a Haskell-  -- file.-  | GHCForeignImportPrim--  -- | Support for patterns of the form @n + k@, where @k@ is an-  -- integer literal.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XNPlusKPatterns>-  | NPlusKPatterns--  -- | Improve the layout rule when @if@ expressions are used in a @do@-  -- block.-  | DoAndIfThenElse--  -- | Enable support for multi-way @if@-expressions.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XMultiWayIf>-  | MultiWayIf--  -- | Enable support lambda-@case@ expressions.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XLambdaCase>-  | LambdaCase--  -- | Makes much of the Haskell sugar be desugared into calls to the-  -- function with a particular name that is in scope.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XRebindableSyntax>-  | RebindableSyntax--  -- | Make @forall@ a keyword in types, which can be used to give the-  -- generalisation explicitly.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XExplicitForAll>-  | ExplicitForAll--  -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in-  -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XDatatypeContexts>-  | DatatypeContexts--  -- | Local (@let@ and @where@) bindings are monomorphic.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XMonoLocalBinds>-  | MonoLocalBinds--  -- | Enable @deriving@ for the 'Data.Functor.Functor' class.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XDeriveFunctor>-  | DeriveFunctor--  -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XDeriveTraversable>-  | DeriveTraversable--  -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XDeriveFoldable>-  | DeriveFoldable--  -- | Enable non-decreasing indentation for @do@ blocks.-  ---  -- * <https://haskell.org/ghc/docs/latest/html/users_guide/bugs.html#context-free-syntax>-  | NondecreasingIndentation--  -- | Allow imports to be qualified with a safe keyword that requires-  -- the imported module be trusted as according to the Safe Haskell-  -- definition of trust.-  ---  -- > import safe Network.Socket-  ---  -- * <https://haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#safe-imports>-  | SafeImports--  -- | Compile a module in the Safe, Safe Haskell mode -- a restricted-  -- form of the Haskell language to ensure type safety.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/safe_haskell.html#ghc-flag--XSafe>-  | Safe--  -- | Compile a module in the Trustworthy, Safe Haskell mode -- no-  -- restrictions apply but the module is marked as trusted as long as-  -- the package the module resides in is trusted.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/safe_haskell.html#ghc-flag--XTrustworthy>-  | Trustworthy--  -- | Compile a module in the Unsafe, Safe Haskell mode so that-  -- modules compiled using Safe, Safe Haskell mode can't import it.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/safe_haskell.html#ghc-flag--XUnsafe>-  | Unsafe--  -- | Allow type class/implicit parameter/equality constraints to be-  -- used as types with the special kind constraint.  Also generalise-  -- the @(ctxt => ty)@ syntax so that any type of kind constraint can-  -- occur before the arrow.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XConstraintKinds>-  | ConstraintKinds--  -- | Enable kind polymorphism.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XPolyKinds>-  | PolyKinds--  -- | Enable datatype promotion.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XDataKinds>-  | DataKinds--  -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/.-  ---  -- * <http://www.haskell.org/haskellwiki/GHC/Data_Parallel_Haskell>-  | ParallelArrays--  -- | Enable explicit role annotations, like in (@type role Foo representational representational@).-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XRoleAnnotations>-  | RoleAnnotations--  -- | Enable overloading of list literals, arithmetic sequences and-  -- list patterns using the 'IsList' type class.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XOverloadedLists>-  | OverloadedLists--  -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XEmptyCase>-  | EmptyCase--  -- | /(deprecated)/ Deprecated in favour of 'DeriveDataTypeable'.-  ---  -- Old description: Triggers the generation of derived 'Typeable'-  -- instances for every datatype and type class declaration.-  ---  -- * <https://haskell.org/ghc/docs/7.8.4/html/users_guide/deriving.html#auto-derive-typeable>-  | AutoDeriveTypeable--  -- | Desugars negative literals directly (without using negate).-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XNegativeLiterals>-  | NegativeLiterals--  -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@).-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XBinaryLiterals>-  | BinaryLiterals--  -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XNumDecimals>-  | NumDecimals--  -- | Enable support for type classes with no type parameter.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XNullaryTypeClasses>-  | NullaryTypeClasses--  -- | Enable explicit namespaces in module import/export lists.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XExplicitNamespaces>-  | ExplicitNamespaces--  -- | Allow the user to write ambiguous types, and the type inference engine to infer them.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XAllowAmbiguousTypes>-  | AllowAmbiguousTypes--  -- | Enable @foreign import javascript@.-  | JavaScriptFFI--  -- | Allow giving names to and abstracting over patterns.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XPatternSynonyms>-  | PatternSynonyms--  -- | Allow anonymous placeholders (underscore) inside type signatures.  The-  -- type inference engine will generate a message describing the type inferred-  -- at the hole's location.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XPartialTypeSignatures>-  | PartialTypeSignatures--  -- | Allow named placeholders written with a leading underscore inside type-  -- signatures.  Wildcards with the same name unify to the same type.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XNamedWildCards>-  | NamedWildCards--  -- | Enable @deriving@ for any class.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XDeriveAnyClass>-  | DeriveAnyClass--  -- | Enable @deriving@ for the 'Language.Haskell.TH.Syntax.Lift' class.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XDeriveLift>-  | DeriveLift--  -- | Enable support for 'static pointers' (and the @static@-  -- keyword) to refer to globally stable names, even across-  -- different programs.-  ---  -- * <https://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#ghc-flag--XStaticPointers>-  | StaticPointers--  -- | Switches data type declarations to be strict by default (as if-  -- they had a bang using @BangPatterns@), and allow opt-in field-  -- laziness using @~@.-  ---  -- * <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#ghc-flag--XStrictData>-  | StrictData--  -- | Switches all pattern bindings to be strict by default (as if-  -- they had a bang using @BangPatterns@), ordinary patterns are-  -- recovered using @~@. Implies @StrictData@.-  ---  -- * <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#ghc-flag--XStrict>-  | Strict--  -- | Allows @do@-notation for types that are @'Applicative'@ as well-  -- as @'Monad'@. When enabled, desugaring @do@ notation tries to use-  -- @(<*>)@ and @'fmap'@ and @'join'@ as far as possible.-  | ApplicativeDo--  -- | Allow records to use duplicated field labels for accessors.-  | DuplicateRecordFields--  -- | Enable explicit type applications with the syntax @id \@Int@.-  | TypeApplications--  -- | Dissolve the distinction between types and kinds, allowing the compiler-  -- to reason about kind equality and therefore enabling GADTs to be promoted-  -- to the type-level.-  | TypeInType--  -- | Allow recursive (and therefore undecidable) super-class relationships.-  | UndecidableSuperClasses--  -- | A temporary extension to help library authors check if their-  -- code will compile with the new planned desugaring of fail.-  | MonadFailDesugaring--  -- | A subset of @TemplateHaskell@ including only quoting.-  | TemplateHaskellQuotes--  -- | Allows use of the @#label@ syntax.-  | OverloadedLabels--  -- | Allow functional dependency annotations on type families to declare them-  -- as injective.-  | TypeFamilyDependencies--  -- | Allow multiple @deriving@ clauses, each optionally qualified with a-  -- /strategy/.-  | DerivingStrategies--  -- | Enable deriving instances via types of the same runtime representation.-  -- Implies 'DerivingStrategies'.-  | DerivingVia--  -- | Enable the use of unboxed sum syntax.-  | UnboxedSums--  -- | Allow use of hexadecimal literal notation for floating-point values.-  | HexFloatLiterals--  -- | Allow @do@ blocks etc. in argument position.-  | BlockArguments--  -- | Allow use of underscores in numeric literals.-  | NumericUnderscores--  -- | Allow @forall@ in constraints.-  | QuantifiedConstraints--  -- | Have @*@ refer to @Type@.-  | StarIsType--  -- | Liberalises deriving to provide instances for empty data types.-  ---  -- * <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#deriving-instances-for-empty-data-types>-  | EmptyDataDeriving--  -- | Enable detection of complete user-supplied kind signatures.-  | CUSKs--  -- | Allows the syntax @import M qualified@.-  | ImportQualifiedPost--  -- | Allow the use of standalone kind signatures.-  | StandaloneKindSignatures--  -- | Enable unlifted newtypes.-  | UnliftedNewtypes--  -- | Use whitespace to determine whether the minus sign stands for negation or subtraction.-  | LexicalNegation--  -- | Enable qualified do-notation desugaring.-  | QualifiedDo--  -- | Enable linear types.-  | LinearTypes--  -- | Enable the generation of selector functions corresponding to record fields.-  | FieldSelectors--  -- | Enable the use of record dot-accessor and updater syntax-  | OverloadedRecordDot--  -- | Enable data types for which an unlifted or levity-polymorphic result kind is inferred.-  | UnliftedDatatypes--  deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data)--instance Binary KnownExtension-instance Structured KnownExtension--instance NFData KnownExtension where rnf = genericRnf---- | Extensions that have been deprecated, possibly paired with another--- extension that replaces it.----deprecatedExtensions :: [(Extension, Maybe Extension)]-deprecatedExtensions =-  [ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns))-  , (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables))-  ]--- NOTE: when adding deprecated extensions that have new alternatives--- we must be careful to make sure that the deprecation messages are--- valid. We must not recommend aliases that cannot be used with older--- compilers, perhaps by adding support in Cabal to translate the new--- name to the old one for older compilers. Otherwise we are in danger--- of the scenario in ticket #689.--instance Pretty Extension where-  pretty (UnknownExtension other) = Disp.text other-  pretty (EnableExtension ke)     = Disp.text (show ke)-  pretty (DisableExtension ke)    = Disp.text ("No" ++ show ke)--instance Parsec Extension where-  parsec = classifyExtension <$> P.munch1 isAlphaNum--instance Pretty KnownExtension where-  pretty ke = Disp.text (show ke)--classifyExtension :: String -> Extension-classifyExtension string-  = case classifyKnownExtension string of-    Just ext -> EnableExtension ext-    Nothing ->-        case string of-        'N':'o':string' ->-            case classifyKnownExtension string' of-            Just ext -> DisableExtension ext-            Nothing -> UnknownExtension string-        _ -> UnknownExtension string---- | 'read' for 'KnownExtension's is really really slow so for the Text--- instance--- what we do is make a simple table indexed off the first letter in the--- extension name. The extension names actually cover the range @'A'-'Z'@--- pretty densely and the biggest bucket is 7 so it's not too bad. We just do--- a linear search within each bucket.------ This gives an order of magnitude improvement in parsing speed, and it'll--- also allow us to do case insensitive matches in future if we prefer.----classifyKnownExtension :: String -> Maybe KnownExtension-classifyKnownExtension "" = Nothing-classifyKnownExtension string@(c : _)-  | inRange (bounds knownExtensionTable) c-  = lookup string (knownExtensionTable ! c)-  | otherwise = Nothing--knownExtensionTable :: Array Char [(String, KnownExtension)]-knownExtensionTable =-  accumArray (flip (:)) [] ('A', 'Z')-    [ (Prelude.head str, (str, extension)) -- assume KnownExtension's Show returns a non-empty string-    | extension <- [toEnum 0 ..]-    , let str = show extension ]