packages feed

Cabal 1.14.0 → 3.16.1.0

raw patch · 238 files changed

Files

Cabal.cabal view
@@ -1,168 +1,416 @@-Name: Cabal-Version: 1.14.0-Copyright: 2003-2006, Isaac Jones-           2005-2011, Duncan Coutts-License: BSD3-License-File: LICENSE-Author: Isaac Jones <ijones@syntaxpolice.org>-        Duncan Coutts <duncan@community.haskell.org>-Maintainer: cabal-devel@haskell.org-Homepage: http://www.haskell.org/cabal/-bug-reports: http://hackage.haskell.org/trac/hackage/-Synopsis: A framework for packaging Haskell software-Description:-        The Haskell Common Architecture for Building Applications and-        Libraries: a framework defining a common interface for authors to more-        easily build their Haskell applications in a portable way.-        .-        The Haskell Cabal is part of a larger infrastructure for distributing,-        organizing, and cataloging Haskell libraries and tools.-Category: Distribution-cabal-version: >=1.10-Build-Type: Custom--- Even though we do use the default Setup.lhs it's vital to bootstrapping--- that we build Setup.lhs using our own local Cabal source code.+cabal-version: 3.6+name:          Cabal+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+homepage:      http://www.haskell.org/cabal/+bug-reports:   https://github.com/haskell/cabal/issues+synopsis:      A framework for packaging Haskell software+description:+  The Haskell Common Architecture for Building Applications and+  Libraries: a framework defining a common interface for authors to more+  easily build their Haskell applications in a portable way.+  .+  The Haskell Cabal is part of a larger infrastructure for distributing,+  organizing, and cataloging Haskell libraries and tools.+category:       Distribution+build-type:     Simple+-- If we use a new Cabal feature, this needs to be changed to Custom so+-- we can bootstrap. -Extra-Source-Files:-        README changelog+extra-doc-files:+  README.md ChangeLog.md  source-repository head-  type:     darcs-  location: http://darcs.haskell.org/cabal/+  type:     git+  location: https://github.com/haskell/cabal/   subdir:   Cabal -Flag base4-    Description: Choose the even newer, even smaller, split-up base package.+flag git-rev+  description: include Git revision hash in version+  default: False+  manual: True -Flag base3-    Description: Choose the new smaller, split-up base package.+library+  default-language: Haskell2010+  hs-source-dirs: src -Library-  build-depends:   base       >= 2   && < 5,-                   filepath   >= 1   && < 1.4-  if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 }-  if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 }-  if flag(base3)-    Build-Depends: directory  >= 1   && < 1.2,-                   process    >= 1   && < 1.2,-                   old-time   >= 1   && < 1.2,-                   containers >= 0.1 && < 0.5,-                   array      >= 0.1 && < 0.5,-                   pretty     >= 1   && < 1.2+  build-depends:+    , 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: unix       >= 2.0 && < 2.6+  if os(windows)+    build-depends:+      , Win32 >= 2.3.0.0 && < 2.15+  else+    build-depends:+      , unix  >= 2.8.6.0 && < 2.9 -  ghc-options: -Wall -fno-ignore-asserts-  if impl(ghc >= 6.8)-    ghc-options: -fwarn-tabs-  nhc98-Options: -K4M+  if flag(git-rev)+    build-depends:+      , githash ^>= 0.1.7.0+    cpp-options: -DGIT_REV -  Exposed-Modules:-        Distribution.Compiler,-        Distribution.InstalledPackageInfo,-        Distribution.License,-        Distribution.Make,-        Distribution.ModuleName,-        Distribution.Package,-        Distribution.PackageDescription,-        Distribution.PackageDescription.Configuration,-        Distribution.PackageDescription.Parse,-        Distribution.PackageDescription.Check,-        Distribution.PackageDescription.PrettyPrint,-        Distribution.ParseUtils,-        Distribution.ReadE,-        Distribution.Simple,-        Distribution.Simple.Build,-        Distribution.Simple.Build.Macros,-        Distribution.Simple.Build.PathsModule,-        Distribution.Simple.BuildPaths,-        Distribution.Simple.Bench,-        Distribution.Simple.Command,-        Distribution.Simple.Compiler,-        Distribution.Simple.Configure,-        Distribution.Simple.GHC,-        Distribution.Simple.LHC,-        Distribution.Simple.Haddock,-        Distribution.Simple.Hpc,-        Distribution.Simple.Hugs,-        Distribution.Simple.Install,-        Distribution.Simple.InstallDirs,-        Distribution.Simple.JHC,-        Distribution.Simple.LocalBuildInfo,-        Distribution.Simple.NHC,-        Distribution.Simple.PackageIndex,-        Distribution.Simple.PreProcess,-        Distribution.Simple.PreProcess.Unlit,-        Distribution.Simple.Program,-        Distribution.Simple.Program.Ar,-        Distribution.Simple.Program.Builtin,-        Distribution.Simple.Program.Db,-        Distribution.Simple.Program.HcPkg,-        Distribution.Simple.Program.Hpc,-        Distribution.Simple.Program.Ld,-        Distribution.Simple.Program.Run,-        Distribution.Simple.Program.Script,-        Distribution.Simple.Program.Types,-        Distribution.Simple.Register,-        Distribution.Simple.Setup,-        Distribution.Simple.SrcDist,-        Distribution.Simple.Test,-        Distribution.Simple.UHC,-        Distribution.Simple.UserHooks,-        Distribution.Simple.Utils,-        Distribution.System,-        Distribution.TestSuite,-        Distribution.Text,-        Distribution.Verbosity,-        Distribution.Version,-        Distribution.Compat.ReadP,-        Language.Haskell.Extension+  ghc-options:+    -Wall+    -fno-ignore-asserts+    -Wtabs+    -Wincomplete-uni-patterns+    -Wincomplete-record-updates+    -Wno-unticked-promoted-constructors -  Other-Modules:-        Distribution.GetOpt,-        Distribution.Compat.Exception,-        Distribution.Compat.CopyFile,-        Distribution.Compat.TempFile,-        Distribution.Simple.GHC.IPI641,-        Distribution.Simple.GHC.IPI642,-        Paths_Cabal+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wnoncanonical-monad-instances -  Default-Language: Haskell98-  Default-Extensions: CPP+  if impl(ghc >= 8.0) && impl(ghc < 8.8)+    ghc-options: -Wnoncanonical-monadfail-instances -test-suite unit-tests-  type: exitcode-stdio-1.0-  main-is: suite.hs-  other-modules: PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check,-                 PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check,-                 PackageTests.BuildDeps.InternalLibrary0.Check,-                 PackageTests.BuildDeps.InternalLibrary1.Check,-                 PackageTests.BuildDeps.InternalLibrary2.Check,-                 PackageTests.BuildDeps.InternalLibrary3.Check,-                 PackageTests.BuildDeps.InternalLibrary4.Check,-                 PackageTests.BuildDeps.TargetSpecificDeps1.Check,-                 PackageTests.BuildDeps.TargetSpecificDeps2.Check,-                 PackageTests.BuildDeps.TargetSpecificDeps3.Check,-                 PackageTests.BuildDeps.SameDepsAllRound.Check,-                 PackageTests.TestOptions.Check,-                 PackageTests.TestStanza.Check,-                 PackageTests.TestSuiteExeV10.Check,-                 PackageTests.BenchmarkStanza.Check,-                 PackageTests.PackageTester-  hs-source-dirs: tests+  exposed-modules:+    Distribution.Backpack.Configure+    Distribution.Backpack.ComponentsGraph+    Distribution.Backpack.ConfiguredComponent+    Distribution.Backpack.DescribeUnitId+    Distribution.Backpack.FullUnitId+    Distribution.Backpack.LinkedComponent+    Distribution.Backpack.ModSubst+    Distribution.Backpack.ModuleShape+    Distribution.Backpack.PreModuleShape+    Distribution.Utils.IOData+    Distribution.Utils.LogProgress+    Distribution.Utils.MapAccum+    Distribution.Compat.CreatePipe+    Distribution.Compat.Directory+    Distribution.Compat.Environment+    Distribution.Compat.FilePath+    Distribution.Compat.Internal.TempFile+    Distribution.Compat.ResponseFile+    Distribution.Compat.Prelude.Internal+    Distribution.Compat.Process+    Distribution.Compat.Stack+    Distribution.Compat.Time+    Distribution.Make+    Distribution.PackageDescription.Check+    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.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+    Distribution.Simple.Program.Builtin+    Distribution.Simple.Program.Db+    Distribution.Simple.Program.Find+    Distribution.Simple.Program.GHC+    Distribution.Simple.Program.HcPkg+    Distribution.Simple.Program.Hpc+    Distribution.Simple.Program.Internal+    Distribution.Simple.Program.Ld+    Distribution.Simple.Program.ResponseFile+    Distribution.Simple.Program.Run+    Distribution.Simple.Program.Script+    Distribution.Simple.Program.Strip+    Distribution.Simple.Program.Types+    Distribution.Simple.Register+    Distribution.Simple.Setup+    Distribution.Simple.ShowBuildInfo+    Distribution.Simple.SrcDist+    Distribution.Simple.Test+    Distribution.Simple.Test.ExeV10+    Distribution.Simple.Test.LibV09+    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.TestSuite+    Distribution.Types.AnnotatedId+    Distribution.Types.ComponentInclude+    Distribution.Types.DumpBuildInfo+    Distribution.Types.PackageName.Magic+    Distribution.Types.ComponentLocalBuildInfo+    Distribution.Types.LocalBuildConfig+    Distribution.Types.LocalBuildInfo+    Distribution.Types.TargetInfo+    Distribution.Types.GivenComponent+    Distribution.Types.ParStrat+    Distribution.Utils.Json+    Distribution.Utils.NubList+    Distribution.Utils.Progress+    Distribution.Verbosity+    Distribution.Verbosity.Internal++  -- 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++  -- Parsec parser-related modules   build-depends:-        base,-        test-framework,-        test-framework-quickcheck2,-        test-framework-hunit,-        HUnit,-        QuickCheck >= 2.1.0.1,-        Cabal,-        process,-        directory,-        filepath,-        extensible-exceptions,-        bytestring,-        unix-  Default-Language: Haskell98+    -- transformers-0.4.0.0 doesn't have record syntax e.g. for Identity+    -- See also https://github.com/ekmett/transformers-compat/issues/35+    , transformers (>= 0.3      && < 0.4) || (>=0.4.1.0 && <0.7)+    , mtl           >= 2.1      && < 2.4+    , parsec        >= 3.1.13.0 && < 3.2++  other-modules:+    Distribution.Backpack.PreExistingComponent+    Distribution.Backpack.ReadyComponent+    Distribution.Backpack.MixLink+    Distribution.Backpack.ModuleScope+    Distribution.Backpack.UnifyM+    Distribution.Backpack.Id+    Distribution.Utils.UnionFind+    Distribution.Compat.Async+    Distribution.Compat.CopyFile+    Distribution.Compat.GetShortPathName+    Distribution.Compat.SnocList+    Distribution.GetOpt+    Distribution.Lex+    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.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++  autogen-modules:+    Paths_Cabal++  other-extensions:+    BangPatterns+    CPP+    DefaultSignatures+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveTraversable+    ExistentialQuantification+    FlexibleContexts+    FlexibleInstances+    GeneralizedNewtypeDeriving+    ImplicitParams+    KindSignatures+    LambdaCase+    NondecreasingIndentation+    OverloadedStrings+    PatternSynonyms+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    Trustworthy+    TypeFamilies+    TypeOperators+    TypeSynonymInstances+    UndecidableInstances
+ ChangeLog.md view
@@ -0,0 +1,1046 @@+# 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](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](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](mailto:emilypi@cohomolo.gy) August 2021+  * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.0.0.md++# 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+  * Pass `cxx-options` with `-optcxx` for GHC >= 8.10+  * Use process jobs when calling subprocesses+  * Require custom-setup for `cabal-version: 1.24` and later+  * Accept `linux-androideabi` as an alias for Android+  * Fix ghci being launched before other sources are built+  * Require cabal-versions >=1.25 to be exact++# 3.2.0.0 [Herbert Valerio Riedel](mailto:hvr@gnu.org) April 2020+  * Change free text `String` fields to use `ShortText` in package description+    and installed package info.+  * Split `Distribution.Types.Flag` and `Distribution.Types.ConfVar`+    `Distribution.Types.GenericPackageDescription`.+  * Add GHC-8.10 support, including new extensions to+    `Language.Haskell.Extension`.+  * Use more `NonEmpty` instead of ordinary lists.+  * Add `Distribution.Utils.Structured` for fingeprinting `Binary` blobs.+  * Add `null`, `length` and `unsafeFromUTF8BS` to `Distribution.Utils.ShortText`.+  * Refactor `Distribution.Utils.IOData` module.+  * Rename `Distribution.Compat.MD5` to `Distribution.Utils.MD5`.+  * Add `safeHead`, `safeTail`, `safeLast` to `Distribution.Utils.Generic`.+  * Add `unsnoc` and `unsnocNE` to `Distribution.Utils.Generic`.+  * Add `Set'` modifier to `Distribution.Parsec.Newtypes`.+  * Add `Distribution.Compat.Async`.++# 3.0.2.0 [Herbert Valerio Riedel](mailto:hvr@gnu.org) April 2020+  * Disallow spaces around colon `:` in Dependency `build-depends` syntax+    ([#6538](https://github.com/haskell/cabal/pull/6538)).+  * Make `configure` accept any `pkg-config --modversion` output+    ([#6541](https://github.com/haskell/cabal/pull/6541)).++# 3.0.1.0 [Herbert Valerio Riedel](mailto:hvr@gnu.org) April 2020+  * Add GHC-8.8 flags to `normaliseGhcFlags`+    ([#6379](https://github.com/haskell/cabal/pull/6379)).+  * Typo fixes+    ([#6372](https://github.com/haskell/cabal/pull/6372)).+  * Limit version number parts to contain at most 9 digits+    ([#6386](https://github.com/haskell/cabal/pull/6386)).+  * Fix boundless sublibrary dependency parse failure+    ([#5846](https://github.com/haskell/cabal/issues/5846)).+  * `cabal check` verifies `cpp-options` more pedantically, allowing only+    options starting with `-D` and `-U`.+  * Don’t rebuild world when new ghc flags that affect how error+    messages are presented is specified.+  * Fix dropExeExtension behaviour on Windows+    ([#6287](https://github.com/haskell/cabal/pull/6287)).++# 3.0.0.0 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) August 2019+  * The 3.0 migration guide gives advice on adapting Custom setup+    scripts to backwards-incompatible changes in this release:+    https://github.com/haskell/cabal/wiki/3.0-migration-guide.+  * Due to [#5119](https://github.com/haskell/cabal/issues/5119), the+    `cabal check` warning for bounds on internal libraries has been+    disabled.+  * Introduce set notation for `^>=` and `==` operators+    ([#5906](https://github.com/haskell/cabal/pull/5906)).+  * 'check' reports warnings for various ghc-\*-options fields separately+    ([#5342](https://github.com/haskell/cabal/issues/5432)).+  * `KnownExtension`: added new extensions `DerivingVia` and+    `EmptyDataDeriving`.+  * Add `extra-dynamic-library-flavours`, to specify extra dynamic library+    flavours to build and install from a .cabal file.+  * `autoconfUserHooks` now passes `--host=$HOST` when cross-compiling+  * Introduce multiple public libraries feature+    ([#5526](https://github.com/haskell/cabal/pull/5526)).+    * New build-depends syntax+    * Add a set of library components to the `Dependency` datatype+    * New `visibility` field in the `library` stanza+    * New `LibraryVisibility` field in `InstalledPackageInfo`+    * New syntax for the `--dependency` Cabal flag+  * Static linking+    * Add `--enable-executable-static` flag for building fully+      static executables (GHC's normal "statish" linking links+      Haskell libraries statically, but libc and system dependencies+      dynamically). This new flag links everything statically.+    * Note you likely want to link against `musl` or another libc that+      supports fully static linking;+      [`glibc` has some issues](https://sourceware.org/glibc/wiki/FAQ#Even_statically_linked_programs_need_some_shared_libraries_which_is_not_acceptable_for_me.__What_can_I_do.3F)+      with fully static linking.+  * Fix corrupted config file header for non-ASCII package names+    ([2557](https://github.com/haskell/cabal/issues/2557)).+  * Extend `Distribution.Simple.Utils.rewriteFileEx` from ASCII to UTF-8 encoding.+  * Change the arguments of `Newtype` class to better suit @DeriveAnyClass@ usage,+    add default implementation in terms of `coerce` / `unsafeCoerce`.+  * Implement support for response file arguments to defaultMain* and cabal-install.+  * Uniformly provide 'Semigroup' instances for `base < 4.9` via `semigroups` package+  * Implement `{cmm,asm}-{sources,options} buildinfo fields for+    separate compilation of C-- and ASM source files (#6033).+  * Setting `debug-info` now implies `library-stripping: False` and+    `executable-stripping: False) ([#2702](https://github.com/haskell/cabal/issues/2702))+  * `Setup.hs copy` and `install` now work in the presence of+    `data-files` that use `**` syntax+    ([#6125](https://github.com/haskell/cabal/issues/6125)).++----++### 2.4.1.1 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) December 2018++  * Fix `--with-compiler` failing to locate compiler on Windows+    ([#5753](https://github.com/haskell/cabal/pull/5753)).+  * Cabal can once again be built with GHC 7.8 and 7.6+    ([#5730](https://github.com/haskell/cabal/pull/5730)).++### 2.4.1.0 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) November 2018++  * Warnings in autogenerated files are now silenced+    ([#5678](https://github.com/haskell/cabal/pull/5678)).+  * Improved recompilation avoidance, especially when using GHC 8.6+    ([#5589](https://github.com/haskell/cabal/pull/5589)).+  * Do not error on empty packagedbs in `getInstalledPackages`+    ([#5516](https://github.com/haskell/cabal/issues/5516)).+++### 2.4.0.1 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) September 2018++  * Allow arguments to be passed to `Setup.hs haddock` for `build-type:configure`+    ([#5503](https://github.com/haskell/cabal/issues/5503)).++# 2.4.0.0 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) September 2018+  * Due to [#5119](https://github.com/haskell/cabal/issues/5119), the+    `cabal check` warning for bounds on internal libraries has been+    disabled.+  * `Distribution.Simple.Haddock` now checks to ensure that it+    does not erroneously call Haddock with no target modules.+    ([#5232](https://github.com/haskell/cabal/issues/5232),+    [#5459](https://github.com/haskell/cabal/issues/5459)).+  * Add `getting` (less general than `to`) Lens combinator,+    `non`) and an optics to access the modules in a component+    of a `PackageDescription` by the `ComponentName`:+    `componentBuildInfo` and `componentModules`+  * Linker `ld-options` are now passed to GHC as `-optl` options+    ([#4925](https://github.com/haskell/cabal/pull/4925)).+  * Add `readGhcEnvironmentFile` to parse GHC environment files.+  * Drop support for GHC 7.4, since it is out of our support window+    (and has been for over a year!)+  * Deprecate `preSDist`, `sDistHook`, and `postSDist` in service of+    `new-sdist`, since they violate key invariants of the new-build+    ecosystem. Use `autogen-modules` and `build-tool-depends` instead.+    ([#5389](https://github.com/haskell/cabal/pull/5389)).+  * Added `--repl-options` flag to `Setup repl` used to pass flags to the+    underlying repl without affecting the `LocalBuildInfo`+    ([#4247](https://github.com/haskell/cabal/issues/4247),+    [#5287](https://github.com/haskell/cabal/pull/5287))+  * `KnownExtension`: added new extensions `BlockArguments`+    ([#5101](https://github.com/haskell/cabal/issues/5101)),+    `NumericUnderscores`+    ([#5130]((https://github.com/haskell/cabal/issues/5130)),+    `QuantifiedConstraints`, and `StarIsType`.+  * `buildDepends` is removed from `PackageDescription`. It had long been+    uselessly hanging about as top-level build-depends already got put+    into per-component condition trees anyway. Now it's finally been put+    out of its misery+    ([#4383](https://github.com/haskell/cabal/issues/4283)).+  * Added `Eta` to `CompilerFlavor` and to known compilers.+  * `cabal haddock` now generates per-component documentation+    ([#5226](https://github.com/haskell/cabal/issues/5226)).+  * Wildcard improvements:+    * Allow `**` wildcards in `data-files`, `extra-source-files` and+      `extra-doc-files`. These allow a limited form of recursive+      matching, and require `cabal-version: 2.4`.+      ([#5284](https://github.com/haskell/cabal/issues/5284),+      [#3178](https://github.com/haskell/cabal/issues/3178), et al.)+    * With `cabal-version: 2.4`, when matching a wildcard, the+      requirement for the full extension to match exactly has been+      loosened. Instead, if the wildcard's extension is a suffix of the+      file's extension, the file will be selected. For example,+      previously `foo.en.html` would not match `*.html`, and+      `foo.solaris.tar.gz` would not match `*.tar.gz`, but now both+      do. This may lead to files unexpectedly being included by `sdist`;+      please audit your package descriptions if you rely on this+      behaviour to keep sensitive data out of distributed packages+      ([#5372](https://github.com/haskell/cabal/pull/5372),+      [#784](https://github.com/haskell/cabal/issues/784),+      [#5057](https://github.com/haskell/cabal/issues/5057)).+    * Wildcard syntax errors (misplaced `*`, etc), wildcards that+      refer to missing directories, and wildcards that do not match+      anything are now all detected by `cabal check`.+    * Wildcard ('globbing') functions have been moved from+      `Distribution.Simple.Utils` to `Distribution.Simple.Glob` and+      have been refactored.+  * Fixed `cxx-options` and `cxx-sources` buildinfo fields for+    separate compilation of C++ source files to correctly build and link+    non-library components ([#5309](https://github.com/haskell/cabal/issues/5309)).+  * Reduced warnings generated by hsc2hs and c2hs when `cxx-options` field+    is present in a component.+  * `cabal check` now warns if `-j` is used in `ghc-options` in a Cabal+    file. ([#5277](https://github.com/haskell/cabal/issues/5277))+  * `install-includes` now works as expected with foreign libraries+    ([#5302](https://github.com/haskell/cabal/issues/5299)).+  * Removed support for JHC.+  * Options listed in `ghc-options`, `cc-options`, `ld-options`,+    `cxx-options`, `cpp-options` are not deduplicated anymore+    ([#4449](https://github.com/haskell/cabal/issues/4449)).+  * Deprecated `cabal hscolour` in favour of `cabal haddock --hyperlink-source` ([#5236](https://github.com/haskell/cabal/pull/5236/)).+  * Recognize `powerpc64le` as architecture PPC64.+  * Cabal now deduplicates more `-I` and `-L` and flags to avoid `E2BIG`+    ([#5356](https://github.com/haskell/cabal/issues/5356)).+  * With `build-type: configure`, avoid using backslashes to delimit+    path components on Windows and warn about other unsafe characters+    in the path to the source directory on all platforms+    ([#5386](https://github.com/haskell/cabal/issues/5386)).+  * `Distribution.PackageDescription.Check.checkPackageFiles` now+    accepts a `Verbosity` argument.+  * Added a parameter to+    `Distribution.Backpack.ConfiguredComponent.toConfiguredComponent` in order to fix+    [#5409](https://github.com/haskell/cabal/issues/5409).+  * Partially silence `abi-depends` warnings+    ([#5465](https://github.com/haskell/cabal/issues/5465)).+  * Foreign libraries are now linked against the threaded RTS when the+    'ghc-options: -threaded' flag is used+    ([#5431](https://github.com/haskell/cabal/pull/5431)).+  * Pass command line arguments to `hsc2hs` using response files when possible+    ([#3122](https://github.com/haskell/cabal/issues/3122)).++----++## 2.2.0.1 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) March 2018++  * Fix `checkPackageFiles` for relative directories ([#5206](https://github.com/haskell/cabal/issues/5206))+++# 2.2.0.0 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) March 2018++  * The 2.2 migration guide gives advice on adapting Custom setup+    scripts to backwards-incompatible changes in this release:+    https://github.com/haskell/cabal/wiki/2.2-migration-guide.+  * New Parsec-based parser for `.cabal` files is now the+    default. This brings memory consumption and speed improvements, as+    well as making new syntax extensions easier to implement.+  * Support for common stanzas (#4751).+  * Added elif-conditionals to `.cabal` syntax (#4750).+  * The package license information can now be specified using the+    SPDX syntax. This requires setting `cabal-version` to 2.2+ (#2547,+    #5050).+  * Support for GHC's numeric -g debug levels (#4673).+  * Compilation with section splitting is now supported via the+    `--enable-split-sections` flag (#4819)+  * Fields with mandatory commas (e.g. build-depends) may now have a+    leading or a trailing comma (either one, not both) (#4953)+  * Added `virtual-modules` field, to allow modules that are not built+    but registered (#4875).+  * Use better defaulting for `build-type`; rename `PackageDescription`'s+    `buildType` field to `buildTypeRaw` and introduce new `buildType`+    function (#4958)+  * `D.T.PackageDescription.allBuildInfo` now returns all build infos, not+    only for buildable components (#5087).+  * Removed `UnknownBuildType` constructor from `BuildType` (#5003).+  * Added `HexFloatLiterals` to `KnownExtension`.+  * Cabal will no longer try to build an empty set of `inputModules`+    (#4890).+  * `copyComponent` and `installIncludeFiles` will now look for+    include headers in the build directory (`dist/build/...` by+    default) as well (#4866).+  * Added `cxx-options` and `cxx-sources` buildinfo fields for+    separate compilation of C++ source files (#3700).+  * Removed unused `--allow-newer`/`--allow-older` support from+    `Setup configure` (#4527).+  * Changed `FlagAssignment` to be an opaque `newtype` (#4849).+  * Changed `rawSystemStdInOut` to use proper type to represent+    binary and textual data; new `Distribution.Utils.IOData` module;+    removed obsolete `startsWithBOM`, `fileHasBOM`, `fromUTF8`,+    and `toUTF8` functions; add new `toUTF8BS`/`toUTF8LBS`+    encoding functions. (#4666)+  * Added a `cabal check` warning when the `.cabal` file name does+    not match package name (#4592).+  * The `ar` program now receives its arguments via a response file+    (`@file`).  Old behaviour can be restored with+    `--disable-response-files` argument to `configure` or+    `install` (#4596).+  * Added `.Lens` modules, with optics for package description data+    types (#4701).+  * Support for building with Win32 version 2.6 (#4835).+  * Change `compilerExtensions` and `ghcOptExtensionMap` to contain+    `Maybe Flag`s, since a supported extension can lack a flag (#4443).+  * Pretty-printing of `.cabal` files is slightly different due to+    parser changes. For an example, see+    https://mail.haskell.org/pipermail/cabal-devel/2017-December/010414.html.+  * `--hyperlink-source` now uses Haddock's hyperlinker backend when+    Haddock is new enough, falling back to HsColour otherwise.+  * `D.S.defaultHookedPackageDesc` has been deprecated in favour of+    `D.S.findHookedPackageDesc` (#4874).+  * `D.S.getHookedBuildInfo` now takes an additional parameter+    specifying the build directory path (#4874).+  * Emit warning when encountering unknown GHC versions (#415).++### 2.0.1.1 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) December 2017++  * Don't pass `other-modules` to stub executable for detailed-0.9+  (#4918).+  * Hpc: Use relative .mix search paths (#4917).++## 2.0.1.0 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) November 2017++  * Support for GHC's numeric -g debug levels (#4673).+  * Added a new `Distribution.Verbosity.modifyVerbosity` combinator+    (#4724).+  * Added a new `cabal check` warning about unused, undeclared or+    non-Unicode flags.  Also, it warns about leading dash, which is+    unusable but accepted if it's unused in conditionals. (#4687)+  * Modify `allBuildInfo` to include foreign library info (#4763).+  * Documentation fixes.++### 2.0.0.2 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) July 2017++  * See http://coldwa.st/e/blog/2017-09-09-Cabal-2-0.html+    for more detailed release notes.+  * The 2.0 migration guide gives advice on adapting Custom setup+    scripts to backwards-incompatible changes in this release:+    https://github.com/haskell/cabal/wiki/2.0-migration-guide+  * Add CURRENT_PACKAGE_VERSION to cabal_macros.h (#4319)+  * Dropped support for versions of GHC earlier than 6.12 (#3111).+  * GHC compatibility window for the Cabal library has been extended+    to five years (#3838).+  * Convenience/internal libraries are now supported (#269).+    An internal library is declared using the stanza `library+    'libname'`.  Packages which use internal libraries can+    result in multiple registrations; thus `--gen-pkg-config`+    can now output a directory of registration scripts rather than+    a single file.+  * Backwards incompatible change to preprocessor interface:+    the function in `PPSuffixHandler` now takes an additional+    `ComponentLocalBuildInfo` specifying the build information+    of the component being preprocessed.+  * Backwards incompatible change to `cabal_macros.h` (#1893): we now+    generate a macro file for each component which contains only+    information about the direct dependencies of that component.+    Consequently, `dist/build/autogen/cabal_macros.h` contains+    only the macros for the library, and is not generated if a+    package has no library; to find the macros for an executable+    named `foobar`, look in `dist/build/foobar/autogen/cabal_macros.h`.+    Similarly, if you used `autogenModulesDir` you should now+    use `autogenComponentModulesDir`, which now requires a+    `ComponentLocalBuildInfo` argument as well in order to+    disambiguate which component the autogenerated files are for.+  * Backwards incompatible change to `Component`: `TestSuite` and+    `Benchmark` no longer have `testEnabled` and+    `benchmarkEnabled`.  If you used+    `enabledTests` or `enabledBenchmarks`, please instead use+    `enabledTestLBIs` and `enabledBenchLBIs`+    (you will need a `LocalBuildInfo` for these functions.)+    Additionally, the semantics of `withTest` and `withBench`+    have changed: they now iterate over all buildable+    such components, regardless of whether or not they have+    been enabled; if you only want enabled components,+    use `withTestLBI` and `withBenchLBI`.+    `finalizePackageDescription` is deprecated:+    its replacement `finalizePD` now takes an extra argument+    `ComponentRequestedSpec` which specifies what components+    are to be enabled: use this instead of modifying the+    `Component` in a `GenericPackageDescription`.  (As+    it's not possible now, `finalizePackageDescription`+    will assume tests/benchmarks are disabled.)+    If you only need to test if a component is buildable+    (i.e., it is marked buildable in the Cabal file)+    use the new function `componentBuildable`.+  * Backwards incompatible change to `PackageName` (#3896):+    `PackageName` is now opaque; conversion to/from `String` now works+    via (old) `unPackageName` and (new) `mkPackageName` functions.+  * Backwards incompatible change to `ComponentId` (#3917):+    `ComponentId` is now opaque; conversion to/from `String` now works+    via `unComponentId` and `mkComponentId` functions.+  * Backwards incompatible change to `AbiHash` (#3921):+    `AbiHash` is now opaque; conversion to/from `String` now works+    via `unAbiHash` and `mkAbiHash` functions.+  * Backwards incompatible change to `FlagName` (#4062):+    `FlagName` is now opaque; conversion to/from `String` now works+    via `unFlagName` and `mkFlagName` functions.+  * Backwards incompatible change to `Version` (#3905):+    Version is now opaque; conversion to/from `[Int]` now works+    via `versionNumbers` and `mkVersion` functions.+  * Add support for `--allow-older` (dual to `--allow-newer`) (#3466)+  * Improved an error message for process output decoding errors+  (#3408).+  * `getComponentLocalBuildInfo`, `withComponentsInBuildOrder`+    and `componentsInBuildOrder` are deprecated in favor of a+    new interface in `Distribution.Types.LocalBuildInfo`.+  * New `autogen-modules` field. Modules that are built automatically at+    setup, like Paths_PACKAGENAME or others created with a build-type+    custom, appear on `other-modules` for the Library, Executable,+    Test-Suite or Benchmark stanzas or also on `exposed-modules` for+    libraries but are not really on the package when distributed. This+    makes commands like sdist fail because the file is not found, so with+    this new field modules that appear there are treated the same way as+    Paths_PACKAGENAME was and there is no need to create complex build+    hooks. Just add the module names on `other-modules` and+    `exposed-modules` as always and on the new `autogen-modules` besides.+  (#3656).+  * New `./Setup configure` flag `--cabal-file`, allowing multiple+  `.cabal` files in a single directory (#3553). Primarily intended for+  internal use.+  * Macros in `cabal_macros.h` are now ifndef'd, so that they+  don't cause an error if the macro is already defined. (#3041)+  * `./Setup configure` now accepts a single argument specifying+    the component to be configured.  The semantics of this mode+    of operation are described in+    <https://github.com/ghc-proposals/ghc-proposals/pull/4>+  * Internal `build-tools` dependencies are now added to PATH+    upon invocation of GHC, so that they can be conveniently+    used via `-pgmF`. (#1541)+  * Add support for new caret-style version range operator `^>=` (#3705)+  * Verbosity `-v` now takes an extended format which allows+    specifying exactly what you want to be logged.  The format is+    `[silent|normal|verbose|debug] flags`, where flags is a space+    separated list of flags. At the moment, only the flags+    +callsite and +callstack are supported; these report the+    call site/stack of a logging output respectively (these+    are only supported if Cabal is built with GHC 8.0/7.10.2+    or greater, respectively).+  * New `Distribution.Utils.ShortText.ShortText` type for representing+    short text strings compactly (#3898)+  * Cabal no longer supports using a version bound to disambiguate+    between an internal and external package (#4020).  This should+    not affect many people, as this mode of use already did not+    work with the dependency solver.+  * Support for "foreign libraries" (#2540), which are Haskell+    libraries intended to be used by foreign languages like C.+    Foreign libraries only work with GHC 7.8 and later.+  * Added a technical preview version of integrated doctest support (#4480).+  * Added a new `scope` field to the executable stanza. Executables+    with `scope: private` get installed into+    $libexecdir/$libexecsubdir. Additionally $libexecdir now has a+    subdir structure similar to $lib(sub)dir to allow installing+    private executables of different packages and package versions+    alongside one another.  Private executables are those that are+    expected to be run by other programs rather than users. (#3461)++## 1.24.2.0 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) December 2016+  * Fixed a bug in the handling of non-buildable components (#4094).+  * Reverted a PVP-noncompliant API change in 1.24.1.0 (#4123).+  * Bumped the directory upper bound to < 1.4 (#4158).++## 1.24.1.0 [Ryan Thomas](mailto:ryan@ryant.org) October 2016+  * API addition: `differenceVersionRanges` (#3519).+  * Fixed reexported-modules display mangling (#3928).+  * Check that the correct cabal-version is specified when the+  extra-doc-files field is present (#3825).+  * Fixed an incorrect invocation of GetShortPathName that was+  causing build failures on Windows (#3649).+  * Linker flags are now set correctly on GHC >= 7.8 (#3443).++# 1.24.0.0 [Ryan Thomas](mailto:ryan@ryant.org) March 2016+  * Support GHC 8.+  * Deal with extra C sources from preprocessors (#238).+  * Include cabal_macros.h when running c2hs (#2600).+  * Don't recompile C sources unless needed (#2601).+  * Read `builddir` option from `CABAL_BUILDDIR` environment variable.+  * Add `--profiling-detail=$level` flag with a default for libraries+    and executables of `exported-functions` and `toplevel-functions`+    respectively (GHC's `-fprof-auto-{exported,top}` flags) (#193).+  * New `custom-setup` stanza to specify setup deps. Setup is also built+    with the cabal_macros.h style macros, for conditional compilation.+  * Support Haddock response files (#2746).+  * Fixed a bug in the Text instance for Platform (#2862).+  * New `setup haddock` option: `--for-hackage` (#2852).+  * New `--show-detail=direct`; like streaming, but allows the test+    program to detect that is connected to a terminal, and works+    reliable with a non-threaded runtime (#2911, and serves as a+    work-around for #2398)+  * Library support for multi-instance package DBs (#2948).+  * Improved the `./Setup configure` solver (#3082, #3076).+  * The `--allow-newer` option can be now used with `./Setup+  configure` (#3163).+  * Added a way to specify extra locations to find OS X frameworks+  in (`extra-framework-dirs`). Can be used both in `.cabal` files and+  as an argument to `./Setup configure` (#3158).+  * Macros `VERSION_$pkgname` and `MIN_VERSION_$pkgname` are now+  also generated for the current package. (#3235).+  * Backpack is supported!  Two new fields supported in Cabal+  files: signatures and mixins; and a new flag+  to setup scripts, `--instantiate-with`.  See+  https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst+  for more details.++----++## 1.22.8.0 [Ryan Thomas](mailto:ryan@ryant.org) March 2016+  * Distribution.Simple.Setup: remove job cap. Fixes #3191.+  * Check all object file suffixes for recompilation. Fixes #3128.+  * Move source files under `src/`. Fixes #3003.++## 1.22.7.0 [Ryan Thomas](mailto:ryan@ryant.org) January 2016+  * Backport #3012 to the 1.22 branch+  * Cabal.cabal: change build-type to Simple+  * Add foldl' import+  * The Cabal part for fully gcc-like response files++## 1.22.6.0 [Ryan Thomas](mailto:ryan@ryant.org) December 2015+  * Relax upper bound to allow upcoming binary-0.8++## 1.22.5.0 [Ryan Thomas](mailto:ryan@ryant.org) November 2015+  * Don't recompile C sources unless needed (#2601). (Luke Iannini)+  * Support Haddock response files.+  * Add frameworks when linking a dynamic library.++## 1.22.4.0 [Ryan Thomas](mailto:ryan@ryant.org) June 2015+  * Add libname install-dirs variable, use it by default. Fixes #2437. (Edward Z. Yang)+  * Reduce temporary directory name length, fixes #2502. (Edward Z. Yang)+  * Workaround for #2527. (Mikhail Glushenkov)++## 1.22.3.0 [Ryan Thomas](mailto:ryan@ryant.org) April 2015+  * Fix for the ghcjs-pkg version number handling (Luite Stegeman)+  * filterConfigureFlags: filter more flags (Mikhail Glushenkov)+  * Cabal check will fail on -fprof-auto passed as a ghc-option - Fixes #2479 (John Chee)++## 1.22.2.0 [Ryan Thomas](mailto:ryan@ryant.org) March 2015+  * Don't pass `--{en,dis}able-profiling` to old setup.+  * Add -Wall police+  * Fix dependencies on `old-time`+  * Fix test interface detailed-0.9 with GHC 7.10+  * Fix HPC tests with GHC 7.10+  * Make sure to pass the package key to ghc+  * Use `--package-{name|version}` when available for Haddock when available+  * Put full package name and version in library names+  * Fully specify package key format, so external tools can generate it.++# 1.22.0.0 [Johan Tibell](mailto:johan.tibell@gmail.com) January 2015+  * Support GHC 7.10.+  * Experimental support for emitting DWARF debug info.+  * Preliminary support for relocatable packages.+  * Allow cabal to be used inside cabal exec environments.+  * hpc: support multiple "ways" (e.g. profiling and vanilla).+  * Support GHCJS.+  * Improved command line documentation.+  * Add `-none` constraint syntax for version ranges (#2093).+  * Make the default doc index file path compiler/arch/os-dependent+  (#2136).+  * Warn instead of dying when generating documentation and hscolour+  isn't installed (455f51622fa38347db62197a04bb0fa5b928ff17).+  * Support the new BinaryLiterals extension+  (1f25ab3c5eff311ada73c6c987061b80e9bbebd9).+  * Warn about `ghc-prof-options: -auto-all` in `cabal check` (#2162).+  * Add preliminary support for multiple instances of the same package+  version installed side-by-side (#2002).+  * New binary build config format - faster build times (#2076).+  * Support module thinning and renaming (#2038).+  * Add a new license type: UnspecifiedLicense (#2141).+  * Remove support for Hugs and nhc98 (#2168).+  * Invoke `tar` with `--formar ustar` if possible in `sdist` (#1903).+  * Replace `--enable-library-coverage` with `--enable-coverage`, which+  enables program coverage for all components (#1945).+  * Suggest that `ExitFailure 9` is probably due to memory+  exhaustion (#1522).+  * Drop support for Haddock < 2.0 (#1808, #1718).+  * Make `cabal test`/`cabal bench` build only what's needed for+  running tests/benchmarks (#1821).+  * Build shared libraries by default when linking executables dynamically.+  * Build profiled libraries by default when profiling executables.++----++### 1.20.0.4 [Ryan Thomas](mailto:ryan@ryant.org) January 2016+  * Cabal.cabal: change build-type to Simple.++### 1.20.0.1 [Johan Tibell](mailto:johan.tibell@gmail.com) May 2014+  * Fix streaming test output.++# 1.20.0.0 [Johan Tibell](mailto:johan.tibell@gmail.com) April 2014+  * Rewrite user guide+  * Fix repl Ctrl+C handling+  * Add haskell-suite compiler support+  * Add __HADDOCK_VERSION__ define+  * Allow specifying exact dependency version using hash+  * Rename extra-html-files to extra-doc-files+  * Add parallel build support for GHC 7.8 and later+  * Don't call ranlib on OS X+  * Avoid re-linking executables, test suites, and benchmarks+  unnecessarily, shortening build times+  * Add `--allow-newer` which allows upper version bounds to be+  ignored+  * Add `--enable-library-stripping`+  * Add command for freezing dependencies+  * Allow repl to be used outside Cabal packages+  * Add `--require-sandbox`+  * Don't use `--strip-unneeded` on OS X or iOS+  * Add new license-files field got additional licenses+  * Fix if(solaris) on some Solaris versions+  * Don't use -dylib-install-name on OS X with GHC > 7.8+  * Add DragonFly as a known OS+  * Improve pretty-printing of Cabal files+  * Add test flag `--show-details=streaming` for real-time test output+  * Add exec command++----++## 1.10.2.0 [Duncan Coutts](mailto:duncan@community.haskell.org) June 2011+  * Include test suites in cabal sdist+  * Fix for conditionals in test suite stanzas in `.cabal` files+  * Fix permissions of directories created during install+  * Fix for global builds when $HOME env var is not set++## 1.10.1.0 [Duncan Coutts](mailto:duncan@community.haskell.org) February 2011+  * Improved error messages when test suites are not enabled+  * Template parameters allowed in test `--test-option(s)` flag+  * Improved documentation of the test feature+  * Relaxed QA check on cabal-version when using test-suite sections+  * `haddock` command now allows both `--hoogle` and `--html` at the same time+  * Find ghc-version-specific instances of the hsc2hs program+  * Preserve file executable permissions in sdist tarballs+  * Pass gcc location and flags to ./configure scripts+  * Get default gcc flags from ghc++# 1.10.0.0 [Duncan Coutts](mailto:duncan@haskell.org) November 2010+  * New cabal test feature+  * Initial support for UHC+  * New default-language and other-languages fields (e.g. Haskell98/2010)+  * New default-extensions and other-extensions fields+  * Deprecated extensions field (for packages using cabal-version >=1.10)+  * Cabal-version field must now only be of the form `>= x.y`+  * Removed deprecated `--copy-prefix=` feature+  * Auto-reconfigure when `.cabal` file changes+  * Workaround for haddock overwriting .hi and .o files when using TH+  * Extra cpp flags used with hsc2hs and c2hs (-D${os}_BUILD_OS etc)+  * New cpp define VERSION_<package> gives string version of dependencies+  * User guide source now in markdown format for easier editing+  * Improved checks and error messages for C libraries and headers+  * Removed BSD4 from the list of suggested licenses+  * Updated list of known language extensions+  * Fix for include paths to allow C code to import FFI stub.h files+  * Fix for intra-package dependencies on OSX+  * Stricter checks on various bits of `.cabal` file syntax+  * Minor fixes for c2hs++----++### 1.8.0.6 [Duncan Coutts](mailto:duncan@haskell.org) June 2010+  * Fix `register --global/--user`++### 1.8.0.4 [Duncan Coutts](mailto:duncan@haskell.org) March 2010+  * Set dylib-install-name for dynalic libs on OSX+  * Stricter configure check that compiler supports a package's extensions+  * More configure-time warnings+  * Hugs can compile Cabal lib again+  * Default datadir now follows prefix on Windows+  * Support for finding installed packages for hugs+  * Cabal version macros now have proper parenthesis+  * Reverted change to filter out deps of non-buildable components+  * Fix for registering inplace when using a specific package db+  * Fix mismatch between $os and $arch path template variables+  * Fix for finding ar.exe on Windows, always pick ghc's version+  * Fix for intra-package dependencies with ghc-6.12++# 1.8.0.2 [Duncan Coutts](mailto:duncan@haskell.org) December 2009+  * Support for GHC-6.12+  * New unique installed package IDs which use a package hash+  * Allow executables to depend on the lib within the same package+  * Dependencies for each component apply only to that component+    (previously applied to all the other components too)+  * Added new known license MIT and versioned GPL and LGPL+  * More liberal package version range syntax+  * Package registration files are now UTF8+  * Support for LHC and JHC-0.7.2+  * Deprecated RecordPuns extension in favour of NamedFieldPuns+  * Deprecated PatternSignatures extension in favor of ScopedTypeVariables+  * New VersionRange semantic view as a sequence of intervals+  * Improved package quality checks+  * Minor simplification in a couple `Setup.hs` hooks+  * Beginnings of a unit level testsuite using QuickCheck+  * Various bug fixes+  * Various internal cleanups++----++### 1.6.0.2 [Duncan Coutts](mailto:duncan@haskell.org) February 2009+  * New configure-time check for C headers and libraries+  * Added language extensions present in ghc-6.10+  * Added support for NamedFieldPuns extension in ghc-6.8+  * Fix in configure step for ghc-6.6 on Windows+  * Fix warnings in `Path_pkgname.hs` module on Windows+  * Fix for exotic flags in ld-options field+  * Fix for using pkg-config in a package with a lib and an executable+  * Fix for building haddock docs for exes that use the Paths module+  * Fix for installing header files in subdirectories+  * Fix for the case of building profiling libs but not ordinary libs+  * Fix read-only attribute of installed files on Windows+  * Ignore ghc -threaded flag when profiling in ghc-6.8 and older++### 1.6.0.1 [Duncan Coutts](mailto:duncan@haskell.org) October 2008+  * Export a compat function to help alex and happy++# 1.6.0.0 [Duncan Coutts](mailto:duncan@haskell.org) October 2008+  * Support for ghc-6.10+  * Source control repositories can now be specified in `.cabal` files+  * Bug report URLs can be now specified in `.cabal` files+  * Wildcards now allowed in data-files and extra-source-files fields+  * New syntactic sugar for dependencies `build-depends: foo ==1.2.*`+  * New cabal_macros.h provides macros to test versions of dependencies+  * Relocatable bindists now possible on unix via env vars+  * New `exposed` field allows packages to be not exposed by default+  * Install dir flags can now use $os and $arch variables+  * New `--builddir` flag allows multiple builds from a single sources dir+  * cc-options now only apply to .c files, not for -fvia-C+  * cc-options are not longer propagated to dependent packages+  * The cpp/cc/ld-options fields no longer use `,` as a separator+  * hsc2hs is now called using gcc instead of using ghc as gcc+  * New api for manipulating sets and graphs of packages+  * Internal api improvements and code cleanups+  * Minor improvements to the user guide+  * Miscellaneous minor bug fixes++----++### 1.4.0.2 [Duncan Coutts](mailto:duncan@haskell.org) August 2008+  * Fix executable stripping default+  * Fix striping exes on OSX that export dynamic symbols (like ghc)+  * Correct the order of arguments given by `--prog-options=`+  * Fix corner case with overlapping user and global packages+  * Fix for modules that use pre-processing and `.hs-boot` files+  * Clarify some points in the user guide and readme text+  * Fix verbosity flags passed to sub-command like haddock+  * Fix `sdist --snapshot`+  * Allow meta-packages that contain no modules or C code+  * Make the generated Paths module -Wall clean on Windows++### 1.4.0.1 [Duncan Coutts](mailto:duncan@haskell.org) June 2008+  * Fix a bug which caused `.` to always be in the sources search path+  * Haddock-2.2 and later do now support the `--hoogle` flag++# 1.4.0.0 [Duncan Coutts](mailto:duncan@haskell.org) June 2008+  * Rewritten command line handling support+  * Command line completion with bash+  * Better support for Haddock 2+  * Improved support for nhc98+  * Removed support for ghc-6.2+  * Haddock markup in `.lhs` files now supported+  * Default colour scheme for highlighted source code+  * Default prefix for `--user` installs is now `$HOME/.cabal`+  * All `.cabal` files are treaded as UTF-8 and must be valid+  * 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 disallows "1.05"+  * Improved user guide introduction+  * Programatica support removed+  * New options `--program-prefix/suffix` allows eg versioned programs+  * Support packages that use `.hs-boot` files+  * Fix sdist for Main modules that require preprocessing+  * New configure -O flag with optimisation level 0--2+  * Provide access to "`x-`" extension fields through the Cabal api+  * Added check for broken installed packages+  * Added warning about using inconsistent versions of dependencies+  * Strip binary executable files by default with an option to disable+  * New options to add site-specific include and library search paths+  * Lift the restriction that libraries must have exposed-modules+  * Many bugs fixed.+  * Many internal structural improvements and code cleanups++----++## 1.2.4.0 [Duncan Coutts](mailto:duncan@haskell.org) June 2008+  * Released with GHC 6.8.3+  * Backported several fixes and minor improvements from Cabal-1.4+  * Use a default colour scheme for sources with hscolour >=1.9+  * Support `--hyperlink-source` for Haddock >= 2.0+  * Fix for running in a non-writable directory+  * Add OSX -framework arguments when linking executables+  * Updates to the user guide+  * Allow build-tools names to include + and _+  * Export autoconfUserHooks and simpleUserHooks+  * Export ccLdOptionsBuildInfo for `Setup.hs` scripts+  * Export unionBuildInfo and make BuildInfo an instance of Monoid+  * Fix to allow the `main-is` module to use a pre-processor++## 1.2.3.0 [Duncan Coutts](mailto:duncan@haskell.org) Nov 2007+  * Released with GHC 6.8.2+  * Includes full list of GHC language extensions+  * Fix infamous `dist/conftest.c` bug+  * Fix `configure --interfacedir=`+  * Find ld.exe on Windows correctly+  * Export PreProcessor constructor and mkSimplePreProcessor+  * Fix minor bug in unlit code+  * Fix some markup in the haddock docs++## 1.2.2.0 [Duncan Coutts](mailto:duncan@haskell.org) Nov 2007+  * Released with GHC 6.8.1+  * Support haddock-2.0+  * Support building DSOs with GHC+  * Require reconfiguring if the `.cabal` file has changed+  * Fix os(windows) configuration test+  * Fix building documentation+  * Fix building packages on Solaris+  * Other minor bug fixes++## 1.2.1 [Duncan Coutts](mailto:duncan@haskell.org) Oct 2007+  * To be included in GHC 6.8.1+  * New field `cpp-options` used when preprocessing Haskell modules+  * Fixes for hsc2hs when using ghc+  * C source code gets compiled with -O2 by default+  * OS aliases, to allow os(windows) rather than requiring os(mingw32)+  * Fix cleaning of `stub` files+  * Fix cabal-setup, command line ui that replaces `runhaskell Setup.hs`+  * Build docs even when dependent packages docs are missing+  * Allow the `--html-dir` to be specified at configure time+  * Fix building with ghc-6.2+  * Other minor bug fixes and build fixes++# 1.2.0  [Duncan Coutts](mailto:duncan.coutts@worc.ox.ac.uk) Sept 2007+  * To be included in GHC 6.8.x+  * New configurations feature+  * Can make haddock docs link to highlighted sources (with hscolour)+  * New flag to allow linking to haddock docs on the web+  * Supports pkg-config+  * New field `build-tools` for tool dependencies+  * Improved c2hs support+  * Preprocessor output no longer clutters source dirs+  * Separate `includes` and `install-includes` fields+  * Makefile command to generate makefiles for building libs with GHC+  * New `--docdir` configure flag+  * Generic `--with-prog` `--prog-args` configure flags+  * Better default installation paths on Windows+  * Install paths can be specified relative to each other+  * License files now installed+  * Initial support for NHC (incomplete)+  * Consistent treatment of verbosity+  * Reduced verbosity of configure step by default+  * Improved helpfulness of output messages+  * Help output now clearer and fits in 80 columns+  * New setup register `--gen-pkg-config` flag for distros+  * Major internal refactoring, hooks api has changed+  * Dozens of bug fixes++----++### 1.1.6.2 [Duncan Coutts](mailto:duncan.coutts@worc.ox.ac.uk) May 2007++  * Released with GHC 6.6.1+  * Handle windows text file encoding for `.cabal` files+  * Fix compiling a executable for profiling that uses Template Haskell+  * Other minor bug fixes and user guide clarifications++### 1.1.6.1 [Duncan Coutts](mailto:duncan.coutts@worc.ox.ac.uk) Oct 2006++  * fix unlit code+  * fix escaping in register.sh++## 1.1.6  [Duncan Coutts](mailto:duncan.coutts@worc.ox.ac.uk) Oct 2006++  * Released with GHC 6.6+  * Added support for hoogle+  * Allow profiling and normal builds of libs to be chosen independently+  * Default installation directories on Win32 changed+  * Register haddock docs with ghc-pkg+  * Get haddock to make hyperlinks to dependent package docs+  * Added BangPatterns language extension+  * Various bug fixes++## 1.1.4  [Duncan Coutts](mailto:duncan.coutts@worc.ox.ac.uk) May 2006++  * Released with GHC 6.4.2+  * Better support for packages that need to install header files+  * cabal-setup added, but not installed by default yet+  * Implemented `setup register --inplace`+  * Have packages exposed by default with ghc-6.2+  * It is no longer necessary to run `configure` before `clean` or `sdist`+  * Added support for ghc's `-split-objs`+  * Initial support for JHC+  * Ignore extension fields in `.cabal` files (fields beginning with "`x-`")+  * Some changes to command hooks API to improve consistency+  * Hugs support improvements+  * Added GeneralisedNewtypeDeriving language extension+  * Added cabal-version field+  * Support hidden modules with haddock+  * Internal code refactoring+  * More bug fixes++## 1.1.3  [Isaac Jones](mailto:ijones@syntaxpolice.org) Sept 2005++  * WARNING: Interfaces not documented in the user's guide may+    change in future releases.+  * Move building of GHCi .o libs to the build phase rather than+  register phase. (from Duncan Coutts)+  * Use .tar.gz for source package extension+  * Uses GHC instead of cpphs if the latter is not available+  * Added experimental "command hooks" which completely override the+  default behavior of a command.+  * Some bugfixes++# 1.1.1  [Isaac Jones](mailto:ijones@syntaxpolice.org) July 2005++  * WARNING: Interfaces not documented in the user's guide may+    change in future releases.+  * Handles recursive modules for GHC 6.2 and GHC 6.4.+  * Added `setup test` command (Used with UserHook)+  * implemented handling of _stub.{c,h,o} files+  * Added support for profiling+  * Changed install prefix of libraries (pref/pkgname-version+    to prefix/pkgname-version/compname-version)+  * Added pattern guards as a language extension+  * Moved some functionality to Language.Haskell.Extension+  * Register / unregister .bat files for windows+  * Exposed more of the API+  * Added support for the hide-all-packages flag in GHC > 6.4+  * Several bug fixes++----++# 1.0  [Isaac Jones](mailto:ijones@syntaxpolice.org) March 11 2005++  * Released with GHC 6.4, Hugs March 2005, and nhc98 1.18+  * Some sanity checking++----++# 0.5  [Isaac Jones](mailto:ijones@syntaxpolice.org) Wed Feb 19 2005++  * __WARNING__: this is a pre-release and the interfaces are+    still likely to change until we reach a 1.0 release.+  * Hooks interfaces changed+  * Added preprocessors to user hooks+  * No more executable-modules or hidden-modules.  Use+    `other-modules` instead.+  * Certain fields moved into BuildInfo, much refactoring+  * `extra-libs` -> `extra-libraries`+  * Added `--gen-script` to configure and unconfigure.+  * `modules-ghc` (etc) now `ghc-modules` (etc)+  * added new fields including `synopsis`+  * Lots of bug fixes+  * spaces can sometimes be used instead of commas+  * A user manual has appeared (Thanks, ross!)+  * for ghc 6.4, configures versioned depends properly+  * more features to `./setup haddock`++----++# 0.4  [Isaac Jones](mailto:ijones@syntaxpolice.org) Sun Jan 16 2005++  * Much thanks to all the awesome fptools hackers who have been+  working hard to build the Haskell Cabal!++  * __Interface Changes__:++    * __WARNING__: this is a pre-release and the interfaces are still+    likely to change until we reach a 1.0 release.++    * Instead of Package.description, you should name your+    description files <something>.cabal.  In particular, we suggest+    that you name it <packagename>.cabal, but this is not enforced+    (yet).  Multiple `.cabal` files in the same directory is an error,+    at least for now.++    * `./setup install --install-prefix` is gone.  Use `./setup copy`+    `--copy-prefix` instead.++    * The `Modules` field is gone.  Use `hidden-modules`,+    `exposed-modules`, and `executable-modules`.++    * `Build-depends` is now a package-only field, and can't go into+    executable stanzas.  Build-depends is a package-to-package+    relationship.++    * Some new fields.  Use the Source.++  * __New Features__++    * Cabal is now included as a package in the CVS version of+    fptools.  That means it'll be released as `-package Cabal` in+    future versions of the compilers, and if you are a bleeding-edge+    user, you can grab it from the CVS repository with the compilers.++    * Hugs compatibility and NHC98 compatibility should both be+    improved.++    * Hooks Interface / Autoconf compatibility: Most of the hooks+    interface is hidden for now, because it's not finalized.  I have+    exposed only `defaultMainWithHooks` and `defaultUserHooks`.  This+    allows you to use a ./configure script to preprocess+    `foo.buildinfo`, which gets merged with `foo.cabal`.  In future+    releases, we'll expose UserHooks, but we're definitely going to+    change the interface to those.  The interface to the two functions+    I've exposed should stay the same, though.++    * ./setup haddock is a baby feature which pre-processes the+    source code with hscpp and runs haddock on it.  This is brand new+    and hardly tested, so you get to knock it around and see what you+    think.++    * Some commands now actually implement verbosity.++    * The preprocessors have been tested a bit more, and seem to work+    OK.  Please give feedback if you use these.++----++# 0.3  [Isaac Jones](mailto:ijones@syntaxpolice.org) Sun Jan 16 2005++  * Unstable snapshot release+  * From now on, stable releases are even.++----++# 0.2  [Isaac Jones](mailto:ijones@syntaxpolice.org)++  * Adds more HUGS support and preprocessor support.
− Distribution/Compat/CopyFile.hs 
@@ -1,115 +0,0 @@-{-# OPTIONS -cpp #-}--- OPTIONS required for ghc-6.4.x compat, and must appear first-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -cpp #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp #-}--- #hide-module Distribution.Compat.CopyFile (-  copyFile,-  copyOrdinaryFile,-  copyExecutableFile,-  setFileOrdinary,-  setFileExecutable,-  setDirOrdinary,-  ) where--#ifdef __GLASGOW_HASKELL__--import Control.Monad-         ( when )-import Control.Exception-         ( bracket, bracketOnError )-import Distribution.Compat.Exception-         ( catchIO )-#if __GLASGOW_HASKELL__ >= 608-import Distribution.Compat.Exception-         ( throwIOIO )-import System.IO.Error-         ( ioeSetLocation )-#endif-import System.Directory-         ( renameFile, removeFile )-import Distribution.Compat.TempFile-         ( openBinaryTempFile )-import System.FilePath-         ( takeDirectory )-import System.IO-         ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf )-import Foreign-         ( allocaBytes )-#endif /* __GLASGOW_HASKELL__ */--#ifndef mingw32_HOST_OS-#if __GLASGOW_HASKELL__ >= 611-import System.Posix.Internals (withFilePath)-#else-import Foreign.C              (withCString)-#endif-import System.Posix.Types-         ( FileMode )-import System.Posix.Internals-         ( c_chmod )-#if __GLASGOW_HASKELL__ >= 608-import Foreign.C-         ( throwErrnoPathIfMinus1_ )-#else-import Foreign.C-         ( throwErrnoIfMinus1_ )-#endif-#endif /* mingw32_HOST_OS */--copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()-copyOrdinaryFile   src dest = copyFile src dest >> setFileOrdinary   dest-copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest--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--setFileMode :: FilePath -> FileMode -> IO ()-setFileMode name m =-#if __GLASGOW_HASKELL__ >= 611-  withFilePath name $ \s -> do-#else-  withCString name $ \s -> do-#endif-#if __GLASGOW_HASKELL__ >= 608-    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)-#else-    throwErrnoIfMinus1_                   name (c_chmod s m)-#endif-#else-setFileOrdinary   _ = return ()-setFileExecutable _ = return ()-#endif--- This happens to be true on Unix and currently on Windows too:-setDirOrdinary = setFileExecutable--copyFile :: FilePath -> FilePath -> IO ()-#ifdef __GLASGOW_HASKELL__-copyFile fromFPath toFPath =-  copy-#if __GLASGOW_HASKELL__ >= 608-    `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile"))-#endif-    where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->-                 bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->-                 do allocaBytes bufferSize $ copyContents hFrom hTmp-                    hClose hTmp-                    renameFile tmpFPath toFPath-          openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"-          cleanTmp (tmpFPath, hTmp) = do-            hClose hTmp          `catchIO` \_ -> return ()-            removeFile tmpFPath  `catchIO` \_ -> return ()-          bufferSize = 4096--          copyContents hFrom hTo buffer = do-                  count <- hGetBuf hFrom buffer bufferSize-                  when (count > 0) $ do-                          hPutBuf hTo buffer count-                          copyContents hFrom hTo buffer-#else-copyFile fromFPath toFPath = readFile fromFPath >>= writeFile toFPath-#endif
− Distribution/Compat/Exception.hs 
@@ -1,61 +0,0 @@-{-# OPTIONS -cpp #-}--- OPTIONS required for ghc-6.4.x compat, and must appear first-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -cpp #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp #-}--#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))-#define NEW_EXCEPTION-#endif--module Distribution.Compat.Exception (-     Exception.IOException,-     onException,-     catchIO,-     catchExit,-     throwIOIO,-     tryIO,-  ) where--import System.Exit-import qualified Control.Exception as Exception--onException :: IO a -> IO b -> IO a-#ifdef NEW_EXCEPTION-onException = Exception.onException-#else-onException io what = io `Exception.catch` \e -> do what-                                                    Exception.throw e-#endif--throwIOIO :: Exception.IOException -> IO a-#ifdef NEW_EXCEPTION-throwIOIO = Exception.throwIO-#else-throwIOIO = Exception.throwIO . Exception.IOException-#endif--tryIO :: IO a -> IO (Either Exception.IOException a)-#ifdef NEW_EXCEPTION-tryIO = Exception.try-#else-tryIO = Exception.tryJust Exception.ioErrors-#endif--catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#ifdef NEW_EXCEPTION-catchIO = Exception.catch-#else-catchIO = Exception.catchJust Exception.ioErrors-#endif--catchExit :: IO a -> (ExitCode -> IO a) -> IO a-#ifdef NEW_EXCEPTION-catchExit = Exception.catch-#else-catchExit = Exception.catchJust exitExceptions-    where exitExceptions (Exception.ExitException ee) = Just ee-          exitExceptions _                            = Nothing-#endif-
− Distribution/Compat/ReadP.hs 
@@ -1,470 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Compat.ReadP--- Copyright   :  (c) The University of Glasgow 2002--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Portability :  portable------ This is a library of parser combinators, originally written by Koen Claessen.--- It parses all alternatives in parallel, so it never keeps hold of--- the beginning of the input string, a common source of space leaks with--- other parsers.  The '(+++)' choice combinator is genuinely commutative;--- it makes no difference which branch is \"shorter\".------ See also Koen's paper /Parallel Parsing Processes/--- (<http://www.cs.chalmers.se/~koen/publications.html>).------ This version of ReadP has been locally hacked to make it H98, by--- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>-----------------------------------------------------------------------------------module Distribution.Compat.ReadP-  (-  -- * The 'ReadP' type-  ReadP,      -- :: * -> *; instance Functor, Monad, MonadPlus--  -- * Primitive operations-  get,        -- :: ReadP Char-  look,       -- :: ReadP String-  (+++),      -- :: ReadP a -> ReadP a -> ReadP a-  (<++),      -- :: ReadP a -> ReadP a -> ReadP a-  gather,     -- :: ReadP a -> ReadP (String, a)--  -- * Other operations-  pfail,      -- :: ReadP a-  satisfy,    -- :: (Char -> Bool) -> ReadP Char-  char,       -- :: Char -> ReadP Char-  string,     -- :: String -> ReadP String-  munch,      -- :: (Char -> Bool) -> ReadP String-  munch1,     -- :: (Char -> Bool) -> ReadP String-  skipSpaces, -- :: ReadP ()-  choice,     -- :: [ReadP a] -> ReadP a-  count,      -- :: Int -> ReadP a -> ReadP [a]-  between,    -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a-  option,     -- :: a -> ReadP a -> ReadP a-  optional,   -- :: ReadP a -> ReadP ()-  many,       -- :: ReadP a -> ReadP [a]-  many1,      -- :: ReadP a -> ReadP [a]-  skipMany,   -- :: ReadP a -> ReadP ()-  skipMany1,  -- :: ReadP a -> ReadP ()-  sepBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]-  sepBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]-  endBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]-  endBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]-  chainr,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a-  chainl,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a-  chainl1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a-  chainr1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a-  manyTill,   -- :: ReadP a -> ReadP end -> ReadP [a]--  -- * Running a parser-  ReadS,      -- :: *; = String -> [(a,String)]-  readP_to_S, -- :: ReadP a -> ReadS a-  readS_to_P  -- :: ReadS a -> ReadP a--  -- * Properties-  -- $properties-  )- where--import Control.Monad( MonadPlus(..), liftM2 )-import Data.Char (isSpace)--infixr 5 +++, <++---- ------------------------------------------------------------------------------ The P type--- is representation type -- should be kept abstract--data P s a-  = Get (s -> P s a)-  | Look ([s] -> P s a)-  | Fail-  | Result a (P s a)-  | Final [(a,[s])] -- invariant: list is non-empty!---- Monad, MonadPlus--instance Monad (P s) where-  return x = Result x Fail--  (Get f)      >>= k = Get (\c -> f c >>= k)-  (Look f)     >>= k = Look (\s -> f s >>= k)-  Fail         >>= _ = Fail-  (Result x p) >>= k = k x `mplus` (p >>= k)-  (Final r)    >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]--  fail _ = Fail--instance MonadPlus (P s) where-  mzero = Fail--  -- most common case: two gets are combined-  Get f1     `mplus` Get f2     = Get (\c -> f1 c `mplus` f2 c)--  -- results are delivered as soon as possible-  Result x p `mplus` q          = Result x (p `mplus` q)-  p          `mplus` Result x q = Result x (p `mplus` q)--  -- fail disappears-  Fail       `mplus` p          = p-  p          `mplus` Fail       = p--  -- two finals are combined-  -- final + look becomes one look and one final (=optimization)-  -- final + sthg else becomes one look and one final-  Final r    `mplus` Final t    = Final (r ++ t)-  Final r    `mplus` Look f     = Look (\s -> Final (r ++ run (f s) s))-  Final r    `mplus` p          = Look (\s -> Final (r ++ run p s))-  Look f     `mplus` Final r    = Look (\s -> Final (run (f s) s ++ r))-  p          `mplus` Final r    = Look (\s -> Final (run p s ++ r))--  -- two looks are combined (=optimization)-  -- look + sthg else floats upwards-  Look f     `mplus` Look g     = Look (\s -> f s `mplus` g s)-  Look f     `mplus` p          = Look (\s -> f s `mplus` p)-  p          `mplus` Look f     = Look (\s -> p `mplus` f s)---- ------------------------------------------------------------------------------ The ReadP type--newtype Parser r s a = R ((a -> P s r) -> P s r)-type ReadP r a = Parser r Char a---- Functor, Monad, MonadPlus--instance Functor (Parser r s) where-  fmap h (R f) = R (\k -> f (k . h))--instance Monad (Parser r s) where-  return x  = R (\k -> k x)-  fail _    = R (\_ -> Fail)-  R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))----instance MonadPlus (Parser r s) where---  mzero = pfail---  mplus = (+++)---- ------------------------------------------------------------------------------ Operations over P--final :: [(a,[s])] -> P s a--- Maintains invariant for Final constructor-final [] = Fail-final r  = Final r--run :: P c a -> ([c] -> [(a, [c])])-run (Get f)      (c:s) = run (f c) s-run (Look f)     s     = run (f s) s-run (Result x p) s     = (x,s) : run p s-run (Final r)    _     = r-run _            _     = []---- ------------------------------------------------------------------------------ Operations over ReadP--get :: ReadP r Char--- ^ Consumes and returns the next character.---   Fails if there is no input left.-get = R Get--look :: ReadP r String--- ^ Look-ahead: returns the part of the input that is left, without---   consuming it.-look = R Look--pfail :: ReadP r a--- ^ Always fails.-pfail = R (\_ -> Fail)--(+++) :: ReadP r a -> ReadP r a -> ReadP r a--- ^ Symmetric choice.-R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)--(<++) :: ReadP a a -> ReadP r a -> ReadP r a--- ^ Local, exclusive, left-biased choice: If left parser---   locally produces any result at all, then right parser is---   not used.-R f <++ q =-  do s <- look-     probe (f return) s 0- where-  probe (Get f')       (c:s) n = probe (f' c) s (n+1 :: Int)-  probe (Look f')      s     n = probe (f' s) s n-  probe p@(Result _ _) _     n = discard n >> R (p >>=)-  probe (Final r)      _     _ = R (Final r >>=)-  probe _              _     _ = q--  discard 0 = return ()-  discard n  = get >> discard (n-1 :: Int)--gather :: ReadP (String -> P Char r) a -> ReadP r (String, a)--- ^ Transforms a parser into one that does the same, but---   in addition returns the exact characters read.---   IMPORTANT NOTE: 'gather' gives a runtime error if its first argument---   is built using any occurrences of readS_to_P.-gather (R m) =-  R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))- where-  gath l (Get f)      = Get (\c -> gath (l.(c:)) (f c))-  gath _ Fail         = Fail-  gath l (Look f)     = Look (\s -> gath l (f s))-  gath l (Result k p) = k (l []) `mplus` gath l p-  gath _ (Final _)    = error "do not use readS_to_P in gather!"---- ------------------------------------------------------------------------------ Derived operations--satisfy :: (Char -> Bool) -> ReadP r Char--- ^ Consumes and returns the next character, if it satisfies the---   specified predicate.-satisfy p = do c <- get; if p c then return c else pfail--char :: Char -> ReadP r Char--- ^ Parses and returns the specified character.-char c = satisfy (c ==)--string :: String -> ReadP r String--- ^ Parses and returns the specified string.-string this = do s <- look; scan this s- where-  scan []     _               = do return this-  scan (x:xs) (y:ys) | x == y = do get >> scan xs ys-  scan _      _               = do pfail--munch :: (Char -> Bool) -> ReadP r String--- ^ Parses the first zero or more characters satisfying the predicate.-munch p =-  do s <- look-     scan s- where-  scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)-  scan _            = do return ""--munch1 :: (Char -> Bool) -> ReadP r String--- ^ Parses the first one or more characters satisfying the predicate.-munch1 p =-  do c <- get-     if p c then do s <- munch p; return (c:s)-            else pfail--choice :: [ReadP r a] -> ReadP r a--- ^ Combines all parsers in the specified list.-choice []     = pfail-choice [p]    = p-choice (p:ps) = p +++ choice ps--skipSpaces :: ReadP r ()--- ^ Skips all whitespace.-skipSpaces =-  do s <- look-     skip s- where-  skip (c:s) | isSpace c = do _ <- get; skip s-  skip _                 = do return ()--count :: Int -> ReadP r a -> ReadP r [a]--- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of---   results is returned.-count n p = sequence (replicate n p)--between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a--- ^ @ between open close p @ parses @open@, followed by @p@ and finally---   @close@. Only the value of @p@ is returned.-between open close p = do _ <- open-                          x <- p-                          _ <- close-                          return x--option :: a -> ReadP r a -> ReadP r a--- ^ @option x p@ will either parse @p@ or return @x@ without consuming---   any input.-option x p = p +++ return x--optional :: ReadP r a -> ReadP r ()--- ^ @optional p@ optionally parses @p@ and always returns @()@.-optional p = (p >> return ()) +++ return ()--many :: ReadP r a -> ReadP r [a]--- ^ Parses zero or more occurrences of the given parser.-many p = return [] +++ many1 p--many1 :: ReadP r a -> ReadP r [a]--- ^ Parses one or more occurrences of the given parser.-many1 p = liftM2 (:) p (many p)--skipMany :: ReadP r a -> ReadP r ()--- ^ Like 'many', but discards the result.-skipMany p = many p >> return ()--skipMany1 :: ReadP r a -> ReadP r ()--- ^ Like 'many1', but discards the result.-skipMany1 p = p >> skipMany p--sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a]--- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.---   Returns a list of values returned by @p@.-sepBy p sep = sepBy1 p sep +++ return []--sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]--- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.---   Returns a list of values returned by @p@.-sepBy1 p sep = liftM2 (:) p (many (sep >> p))--endBy :: ReadP r a -> ReadP r sep -> ReadP r [a]--- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended---   by @sep@.-endBy p sep = many (do x <- p ; _ <- sep ; return x)--endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]--- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended---   by @sep@.-endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)--chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a--- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.---   Returns a value produced by a /right/ associative application of all---   functions returned by @op@. If there are no occurrences of @p@, @x@ is---   returned.-chainr p op x = chainr1 p op +++ return x--chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a--- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.---   Returns a value produced by a /left/ associative application of all---   functions returned by @op@. If there are no occurrences of @p@, @x@ is---   returned.-chainl p op x = chainl1 p op +++ return x--chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a--- ^ Like 'chainr', but parses one or more occurrences of @p@.-chainr1 p op = scan-  where scan   = p >>= rest-        rest x = do f <- op-                    y <- scan-                    return (f x y)-                 +++ return x--chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a--- ^ Like 'chainl', but parses one or more occurrences of @p@.-chainl1 p op = p >>= rest-  where rest x = do f <- op-                    y <- p-                    rest (f x y)-                 +++ return x--manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a]--- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@---   succeeds. Returns a list of values returned by @p@.-manyTill p end = scan-  where scan = (end >> return []) <++ (liftM2 (:) p scan)---- ------------------------------------------------------------------------------ Converting between ReadP and Read--readP_to_S :: ReadP a a -> ReadS a--- ^ Converts a parser into a Haskell ReadS-style function.---   This is the main way in which you can \"run\" a 'ReadP' parser:---   the expanded type is--- @ readP_to_S :: ReadP a -> String -> [(a,String)] @-readP_to_S (R f) = run (f return)--readS_to_P :: ReadS a -> ReadP r a--- ^ Converts a Haskell ReadS-style function into a parser.---   Warning: This introduces local backtracking in the resulting---   parser, and therefore a possible inefficiency.-readS_to_P r =-  R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))---- ------------------------------------------------------------------------------ QuickCheck properties that hold for the combinators--{- $properties-The following are QuickCheck specifications of what the combinators do.-These can be seen as formal specifications of the behavior of the-combinators.--We use bags to give semantics to the combinators.-->  type Bag a = [a]--Equality on bags does not care about the order of elements.-->  (=~) :: Ord a => Bag a -> Bag a -> Bool->  xs =~ ys = sort xs == sort ys--A special equality operator to avoid unresolved overloading-when testing the properties.-->  (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool->  (=~.) = (=~)--Here follow the properties:-->  prop_Get_Nil =->    readP_to_S get [] =~ []->->  prop_Get_Cons c s =->    readP_to_S get (c:s) =~ [(c,s)]->->  prop_Look s =->    readP_to_S look s =~ [(s,s)]->->  prop_Fail s =->    readP_to_S pfail s =~. []->->  prop_Return x s =->    readP_to_S (return x) s =~. [(x,s)]->->  prop_Bind p k s =->    readP_to_S (p >>= k) s =~.->      [ ys''->      | (x,s') <- readP_to_S p s->      , ys''   <- readP_to_S (k (x::Int)) s'->      ]->->  prop_Plus p q s =->    readP_to_S (p +++ q) s =~.->      (readP_to_S p s ++ readP_to_S q s)->->  prop_LeftPlus p q s =->    readP_to_S (p <++ q) s =~.->      (readP_to_S p s +<+ readP_to_S q s)->   where->    [] +<+ ys = ys->    xs +<+ _  = xs->->  prop_Gather s =->    forAll readPWithoutReadS $ \p ->->      readP_to_S (gather p) s =~->	 [ ((pre,x::Int),s')->	 | (x,s') <- readP_to_S p s->	 , let pre = take (length s - length s') s->	 ]->->  prop_String_Yes this s =->    readP_to_S (string this) (this ++ s) =~->      [(this,s)]->->  prop_String_Maybe this s =->    readP_to_S (string this) s =~->      [(this, drop (length this) s) | this `isPrefixOf` s]->->  prop_Munch p s =->    readP_to_S (munch p) s =~->      [(takeWhile p s, dropWhile p s)]->->  prop_Munch1 p s =->    readP_to_S (munch1 p) s =~->      [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]->->  prop_Choice ps s =->    readP_to_S (choice ps) s =~.->      readP_to_S (foldr (+++) pfail ps) s->->  prop_ReadS r s =->    readP_to_S (readS_to_P r) s =~. r s--}-
− Distribution/Compat/TempFile.hs 
@@ -1,204 +0,0 @@-{-# OPTIONS -cpp #-}--- OPTIONS required for ghc-6.4.x compat, and must appear first-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -cpp #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp #-}--- #hide-module Distribution.Compat.TempFile (-  openTempFile,-  openBinaryTempFile,-  openNewBinaryFile,-  createTempDirectory,-  ) where---import System.FilePath        ((</>))-import Foreign.C              (eEXIST)--#if __NHC__ || __HUGS__-import System.IO              (openFile, openBinaryFile,-                               Handle, IOMode(ReadWriteMode))-import System.Directory       (doesFileExist)-import System.FilePath        ((<.>), splitExtension)-import System.IO.Error        (try, isAlreadyExistsError)-#else-import System.IO              (Handle, openTempFile, openBinaryTempFile)-import Data.Bits              ((.|.))-import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR,-                               o_BINARY, o_NONBLOCK, o_NOCTTY)-import System.IO.Error        (isAlreadyExistsError)-#if __GLASGOW_HASKELL__ >= 611-import System.Posix.Internals (withFilePath)-#else-import Foreign.C              (withCString)-#endif-import Foreign.C              (CInt)-#if __GLASGOW_HASKELL__ >= 611-import GHC.IO.Handle.FD       (fdToHandle)-#else-import GHC.Handle             (fdToHandle)-#endif-import Distribution.Compat.Exception (onException, tryIO)-#endif-import Foreign.C              (getErrno, errnoToIOError)--#if __NHC__-import System.Posix.Types     (CPid(..))-foreign import ccall unsafe "getpid" c_getpid :: IO CPid-#else-import System.Posix.Internals (c_getpid)-#endif--#ifdef mingw32_HOST_OS-import System.Directory       ( createDirectory )-#else-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: Not sure about jhc--#if __NHC__ || __HUGS__--- use a temporary filename that doesn't already exist.--- NB. *not* secure (we don't atomically lock the tmp file we get)-openTempFile :: FilePath -> String -> IO (FilePath, Handle)-openTempFile tmp_dir template-  = do x <- getProcessID-       findTempName x-  where-    (templateBase, templateExt) = splitExtension template-    findTempName :: Int -> IO (FilePath, Handle)-    findTempName x-      = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt-           b  <- doesFileExist path-           if b then findTempName (x+1)-                else do hnd <- openFile path ReadWriteMode-                        return (path, hnd)--openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)-openBinaryTempFile tmp_dir template-  = do x <- getProcessID-       findTempName x-  where-    (templateBase, templateExt) = splitExtension template-    findTempName :: Int -> IO (FilePath, Handle)-    findTempName x-      = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt-           b  <- doesFileExist path-           if b then findTempName (x+1)-                else do hnd <- openBinaryFile path ReadWriteMode-                        return (path, hnd)--openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)-openNewBinaryFile = openBinaryTempFile--getProcessID :: IO Int-getProcessID = fmap fromIntegral c_getpid-#else--- This is a copy/paste of the openBinaryTempFile definition, but--- if uses 666 rather than 600 for the permissions. The base library--- needs to be changed to make this better.-openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)-openNewBinaryFile dir template = do-  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 filepath 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--#if __GLASGOW_HASKELL__ < 611-    withFilePath = withCString-#endif--    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 filepath is,-         -- as any exceptions etc will only be able to report the-         -- fd currently-         h <--#if __GLASGOW_HASKELL__ >= 609-              fdToHandle fd-#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS)-              -- fdToHandle is borked on Windows with ghc-6.6.x-              openFd (fromIntegral fd) Nothing False filepath-                                       ReadWriteMode True-#else-              fdToHandle (fromIntegral fd)-#endif-              `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: Should use filepath library-pathSeparator :: Char-#ifdef mingw32_HOST_OS-pathSeparator = '\\'-#else-pathSeparator = '/'-#endif---- 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-#endif--createTempDirectory :: FilePath -> String -> IO FilePath-createTempDirectory dir template = do-  pid <- c_getpid-  findTempName pid-  where-    findTempName x = do-      let dirpath = dir </> template ++ "-" ++ show x-      r <- tryIO $ mkPrivateDir dirpath-      case r of-        Right _ -> return dirpath-        Left  e | isAlreadyExistsError e -> findTempName (x+1)-                | otherwise              -> ioError e--mkPrivateDir :: String -> IO ()-#ifdef mingw32_HOST_OS-mkPrivateDir s = createDirectory s-#else-mkPrivateDir s = System.Posix.createDirectory s 0o700-#endif
− Distribution/Compiler.hs 
@@ -1,158 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Compiler--- Copyright   :  Isaac Jones 2003-2004------ 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 progconf--- >   JHC -> JHC.getInstalledPackages verbosity packageDb progconf------ 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 #50.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Compiler (-  -- * Compiler flavor-  CompilerFlavor(..),-  buildCompilerFlavor,-  defaultCompilerFlavor,-  parseCompilerFlavorCompat,--  -- * Compiler id-  CompilerId(..),-  ) where--import Distribution.Version (Version(..))--import qualified System.Info (compilerName)-import Distribution.Text (Text(..), display)-import qualified Distribution.Compat.ReadP as Parse-import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint ((<>))--import qualified Data.Char as Char (toLower, isDigit, isAlphaNum)-import Control.Monad (when)--data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC-                    | OtherCompiler String-  deriving (Show, Read, Eq, Ord)--knownCompilerFlavors :: [CompilerFlavor]-knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]--instance Text CompilerFlavor where-  disp (OtherCompiler name) = Disp.text name-  disp NHC                  = Disp.text "nhc98"-  disp other                = Disp.text (lowercase (show other))--  parse = do-    comp <- Parse.munch1 Char.isAlphaNum-    when (all Char.isDigit comp) Parse.pfail-    return (classifyCompilerFlavor comp)--classifyCompilerFlavor :: String -> CompilerFlavor-classifyCompilerFlavor s =-  case lookup (lowercase s) compilerMap of-    Just compiler -> compiler-    Nothing       -> OtherCompiler s-  where-    compilerMap = [ (display compiler, compiler)-                  | compiler <- knownCompilerFlavors ]-----TODO: In some future release, remove 'parseCompilerFlavorCompat' and use--- ordinary 'parse'. Also add ("nhc", NHC) to the above 'compilerMap'.---- | Like 'classifyCompilerFlavor' but compatible with the old ReadS parser.------ It is compatible in the sense that it accepts only the same strings,--- eg "GHC" but not "ghc". However other strings get mapped to 'OtherCompiler'.--- The point of this is that we do not allow extra valid values that would--- upset older Cabal versions that had a stricter parser however we cope with--- new values more gracefully so that we'll be able to introduce new value in--- future without breaking things so much.----parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor-parseCompilerFlavorCompat = do-  comp <- Parse.munch1 Char.isAlphaNum-  when (all Char.isDigit comp) Parse.pfail-  case lookup comp compilerMap of-    Just compiler -> return compiler-    Nothing       -> return (OtherCompiler comp)-  where-    compilerMap = [ (show compiler, compiler)-                  | compiler <- knownCompilerFlavors-                  , compiler /= YHC ]--buildCompilerFlavor :: CompilerFlavor-buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName---- | 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---- --------------------------------------------------------------- * Compiler Id--- --------------------------------------------------------------data CompilerId = CompilerId CompilerFlavor Version-  deriving (Eq, Ord, Read, Show)--instance Text CompilerId where-  disp (CompilerId f (Version [] _)) = disp f-  disp (CompilerId f v) = disp f <> Disp.char '-' <> disp v--  parse = do-    flavour <- parse-    version <- (Parse.char '-' >> parse) Parse.<++ return (Version [] [])-    return (CompilerId flavour version)--lowercase :: String -> String-lowercase = map Char.toLower
− Distribution/GetOpt.hs 
@@ -1,335 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.GetOpt--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Portability :  portable------ This library provides facilities for parsing the command-line options--- in a standalone program.  It is essentially a Haskell port of the GNU--- @getopt@ library.-----------------------------------------------------------------------------------{--Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small-changes Dec. 1997)--Two rather obscure features are missing: The Bash 2.0 non-option hack-(if you don't already know it, you probably don't want to hear about-it...) and the recognition of long options with a single dash-(e.g. '-help' is recognised as '--help', as long as there is no short-option 'h').--Other differences between GNU's getopt and this implementation:--* To enforce a coherent description of options and arguments, there-  are explanation fields in the option/argument descriptor.--* Error messages are now more informative, but no longer POSIX-  compliant... :-(--And a final Haskell advertisement: The GNU C implementation uses well-over 1100 lines, we need only 195 here, including a 46 line example!-:-)--}---- #hide-module Distribution.GetOpt (-   -- * GetOpt-   getOpt, getOpt',-   usageInfo,-   ArgOrder(..),-   OptDescr(..),-   ArgDescr(..),--   -- * Example--   -- $example-) where--import Data.List ( isPrefixOf, intersperse, find )---- |What to do with options following non-options-data ArgOrder a-  = RequireOrder                -- ^ no option processing after first non-option-  | Permute                     -- ^ freely intersperse options and non-options-  | ReturnInOrder (String -> a) -- ^ wrap non-options into options--{-|-Each 'OptDescr' describes a single option.--The arguments to 'Option' are:--* list of short option characters--* list of long option strings (without \"--\")--* argument descriptor--* explanation of option for user--}-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---- |Describes whether an option takes an argument or not, and if so--- how the argument is injected into a value of type @a@.-data ArgDescr a-   = NoArg                   a         -- ^   no argument expected-   | ReqArg (String       -> a) String -- ^   option requires argument-   | OptArg (Maybe String -> a) String -- ^   optional argument--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...---- | 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 header optDescr = unlines (header:table)-   where (ss,ls,ds) = unzip3 [ (sepBy ", " (map (fmtShort ad) sos)-                               ,concatMap (fmtLong  ad) (take 1 los)-                               ,d)-                             | Option sos los ad d <- optDescr ]-         ssWidth    = (maximum . map length) ss-         lsWidth    = (maximum . map length) ls-         dsWidth    = 30 `max` (80 - (ssWidth + lsWidth + 3))-         table      = [ " " ++ padTo ssWidth so' ++-                        " " ++ padTo lsWidth lo' ++-                        " " ++ d'-                      | (so,lo,d) <- zip3 ss ls ds-                      , (so',lo',d') <- fmtOpt dsWidth so lo d ]-         padTo n x  = take n (x ++ repeat ' ')-         sepBy s    = concat . intersperse s--fmtOpt :: Int -> String -> String -> String -> [(String, String, String)]-fmtOpt descrWidth so lo descr =-   case wrapText descrWidth descr of-     []     -> [(so,lo,"")]-     (d:ds) -> (so,lo,d) : [ ("","",d') | d' <- ds ]--fmtShort :: ArgDescr a -> Char -> String-fmtShort (NoArg  _   ) so = "-" ++ [so]-fmtShort (ReqArg _  _) so = "-" ++ [so]-fmtShort (OptArg _  _) so = "-" ++ [so]--fmtLong :: ArgDescr a -> String -> String-fmtLong (NoArg  _   ) lo = "--" ++ lo-fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad-fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"--wrapText :: Int -> String -> [String]-wrapText width = map unwords . wrap 0 [] . words-  where wrap :: Int -> [String] -> [String] -> [[String]]-        wrap 0   []   (w:ws)-          | length w + 1 > width-          = wrap (length w) [w] ws-        wrap col line (w:ws)-          | col + length w + 1 > width-          = reverse line : wrap 0 [] (w:ws)-        wrap col line (w:ws)-          = let col' = col + length w + 1-             in wrap col' (w:line) ws-        wrap _ []   [] = []-        wrap _ line [] = [reverse line]--{-|-Process the command-line, and return the list of values that matched-(and those that didn\'t). The arguments are:--* The order requirements (see 'ArgOrder')--* The option descriptions (see 'OptDescr')--* The actual command line arguments (presumably got from-  'System.Environment.getArgs').--'getOpt' returns a triple consisting of the option arguments, a list-of non-options, and a list of error messages.--}-getOpt :: ArgOrder a                   -- non-option handling-       -> [OptDescr a]                 -- option descriptors-       -> [String]                     -- the command-line arguments-       -> ([a],[String],[String])      -- (options,non-options,error messages)-getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)-   where (os,xs,us,es) = getOpt' ordering optDescr args--{-|-This is almost the same as 'getOpt', but returns a quadruple-consisting of the option arguments, a list of non-options, a list of-unrecognized options, and a list of error messages.--}-getOpt' :: ArgOrder a                         -- non-option handling-        -> [OptDescr a]                       -- option descriptors-        -> [String]                           -- the command-line arguments-        -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)-getOpt' _        _        []         =  ([],[],[],[])-getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering-   where procNextOpt (Opt o)      _                 = (o:os,xs,us,es)-         procNextOpt (UnreqOpt u) _                 = (os,xs,u:us,es)-         procNextOpt (NonOpt x)   RequireOrder      = ([],x:rest,[],[])-         procNextOpt (NonOpt x)   Permute           = (os,x:xs,us,es)-         procNextOpt (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)--         (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)---- handle long option-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-                          , find (p opt) xs /= Nothing]-         exact     = getWith (==)-         options   = if null exact then getWith isPrefixOf else exact-         ads       = [ ad | Option _ _ ad _ <- options ]-         optStr    = ("--"++opt)--         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)---- handle short option-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]--        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)---- miscellaneous error formatting--errAmbig :: [OptDescr a] -> String -> OptKind a-errAmbig ods optStr = OptErr (usageInfo header ods)-   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")--errUnrec :: String -> String-errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"--errNoArg :: String -> OptKind a-errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")--{---------------------------------------------------------------------------------------------- and here a small and hopefully enlightening example:--data Flag = Verbose | Version | Name String | Output String | Arg String   deriving Show--options :: [OptDescr Flag]-options =-   [Option ['v']     ["verbose"]           (NoArg Verbose)      "verbosely list files",-    Option ['V','?'] ["version","release"] (NoArg Version)      "show version info",-    Option ['o']     ["output"]            (OptArg out "FILE")  "use FILE for dump",-    Option ['n']     ["name"]              (ReqArg Name "USER") "only dump USER's files"]--out :: Maybe String -> Flag-out Nothing  = Output "stdout"-out (Just o) = Output o--test :: ArgOrder Flag -> [String] -> String-test order cmdline = case getOpt order options cmdline of-                        (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n ++ "\n"-                        (_,_,errs) -> concat errs ++ usageInfo header options-   where header = "Usage: foobar [OPTION...] files..."---- example runs:--- putStr (test RequireOrder ["foo","-v"])---    ==> options=[]  args=["foo", "-v"]--- putStr (test Permute ["foo","-v"])---    ==> options=[Verbose]  args=["foo"]--- putStr (test (ReturnInOrder Arg) ["foo","-v"])---    ==> options=[Arg "foo", Verbose]  args=[]--- putStr (test Permute ["foo","--","-v"])---    ==> options=[]  args=["foo", "-v"]--- putStr (test Permute ["-?o","--name","bar","--na=baz"])---    ==> options=[Version, Output "stdout", Name "bar", Name "baz"]  args=[]--- putStr (test Permute ["--ver","foo"])---    ==> option `--ver' is ambiguous; could be one of:---          -v      --verbose             verbosely list files---          -V, -?  --version, --release  show version info---        Usage: foobar [OPTION...] files...---          -v        --verbose             verbosely list files---          -V, -?    --version, --release  show version info---          -o[FILE]  --output[=FILE]       use FILE for dump---          -n USER   --name=USER           only dump USER's files--------------------------------------------------------------------------------------------}--{- $example--To hopefully illuminate the role of the different data-structures, here\'s the command-line options for a (very simple)-compiler:-->    module Opts where->->    import Distribution.GetOpt->    import Data.Maybe ( fromMaybe )->->    data Flag->     = Verbose  | Version->     | Input String | Output String | LibDir String->       deriving Show->->    options :: [OptDescr Flag]->    options =->     [ Option ['v']     ["verbose"] (NoArg Verbose)       "chatty output on stderr"->     , Option ['V','?'] ["version"] (NoArg Version)       "show version number"->     , Option ['o']     ["output"]  (OptArg outp "FILE")  "output FILE"->     , Option ['c']     []          (OptArg inp  "FILE")  "input FILE"->     , Option ['L']     ["libdir"]  (ReqArg LibDir "DIR") "library directory"->     ]->->    inp,outp :: Maybe String -> Flag->    outp = Output . fromMaybe "stdout"->    inp  = Input  . fromMaybe "stdin"->->    compilerOpts :: [String] -> IO ([Flag], [String])->    compilerOpts argv =->       case getOpt Permute options argv of->          (o,n,[]  ) -> return (o,n)->          (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))->      where header = "Usage: ic [OPTION...] files..."---}
− Distribution/InstalledPackageInfo.hs 
@@ -1,294 +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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of the University nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}---- This module is meant to be local-only to Distribution...--module Distribution.InstalledPackageInfo (-        InstalledPackageInfo_(..), InstalledPackageInfo,-        ParseResult(..), PError(..), PWarning,-        emptyInstalledPackageInfo,-        parseInstalledPackageInfo,-        showInstalledPackageInfo,-        showInstalledPackageInfoField,-        fieldsInstalledPackageInfo,-  ) where--import Distribution.ParseUtils-         ( FieldDescr(..), ParseResult(..), PError(..), PWarning-         , simpleField, listField, parseLicenseQ-         , showFields, showSingleNamedField, parseFieldsFlat-         , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ-         , showFilePath, showToken, boolField, parseOptVersion-         , parseFreeText, showFreeText )-import Distribution.License     ( License(..) )-import Distribution.Package-         ( PackageName(..), PackageIdentifier(..), PackageId, InstalledPackageId(..)-         , packageName, packageVersion )-import qualified Distribution.Package as Package-         ( Package(..) )-import Distribution.ModuleName-         ( ModuleName )-import Distribution.Version-         ( Version(..) )-import Distribution.Text-         ( Text(disp, parse) )---- -------------------------------------------------------------------------------- The InstalledPackageInfo type--data InstalledPackageInfo_ m-   = InstalledPackageInfo {-        -- these parts are exactly the same as PackageDescription-        installedPackageId :: InstalledPackageId,-        sourcePackageId    :: PackageId,-        license           :: License,-        copyright         :: String,-        maintainer        :: String,-        author            :: String,-        stability         :: String,-        homepage          :: String,-        pkgUrl            :: String,-        synopsis          :: String,-        description       :: String,-        category          :: String,-        -- these parts are required by an installed package only:-        exposed           :: Bool,-        exposedModules    :: [m],-        hiddenModules     :: [m],-        trusted           :: Bool,-        importDirs        :: [FilePath],  -- contain sources in case of Hugs-        libraryDirs       :: [FilePath],-        hsLibraries       :: [String],-        extraLibraries    :: [String],-        extraGHCiLibraries:: [String],    -- overrides extraLibraries for GHCi-        includeDirs       :: [FilePath],-        includes          :: [String],-        depends           :: [InstalledPackageId],-        hugsOptions       :: [String],-        ccOptions         :: [String],-        ldOptions         :: [String],-        frameworkDirs     :: [FilePath],-        frameworks        :: [String],-        haddockInterfaces :: [FilePath],-        haddockHTMLs      :: [FilePath]-    }-    deriving (Read, Show)--instance Package.Package          (InstalledPackageInfo_ str) where-   packageId = sourcePackageId--type InstalledPackageInfo = InstalledPackageInfo_ ModuleName--emptyInstalledPackageInfo :: InstalledPackageInfo_ m-emptyInstalledPackageInfo-   = InstalledPackageInfo {-        installedPackageId = InstalledPackageId "",-        sourcePackageId    = PackageIdentifier (PackageName "") noVersion,-        license           = AllRightsReserved,-        copyright         = "",-        maintainer        = "",-        author            = "",-        stability         = "",-        homepage          = "",-        pkgUrl            = "",-        synopsis          = "",-        description       = "",-        category          = "",-        exposed           = False,-        exposedModules    = [],-        hiddenModules     = [],-        trusted           = False,-        importDirs        = [],-        libraryDirs       = [],-        hsLibraries       = [],-        extraLibraries    = [],-        extraGHCiLibraries= [],-        includeDirs       = [],-        includes          = [],-        depends           = [],-        hugsOptions       = [],-        ccOptions         = [],-        ldOptions         = [],-        frameworkDirs     = [],-        frameworks        = [],-        haddockInterfaces = [],-        haddockHTMLs      = []-    }--noVersion :: Version-noVersion = Version{ versionBranch=[], versionTags=[] }---- -------------------------------------------------------------------------------- Parsing--parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo-parseInstalledPackageInfo =-    parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo---- -------------------------------------------------------------------------------- Pretty-printing--showInstalledPackageInfo :: InstalledPackageInfo -> String-showInstalledPackageInfo = showFields fieldsInstalledPackageInfo--showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)-showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo---- -------------------------------------------------------------------------------- Description of the fields, for parsing/printing--fieldsInstalledPackageInfo :: [FieldDescr InstalledPackageInfo]-fieldsInstalledPackageInfo = basicFieldDescrs ++ installedFieldDescrs--basicFieldDescrs :: [FieldDescr InstalledPackageInfo]-basicFieldDescrs =- [ simpleField "name"-                           disp                   parsePackageNameQ-                           packageName            (\name pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgName=name}})- , simpleField "version"-                           disp                   parseOptVersion-                           packageVersion         (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}})- , simpleField "id"-                           disp                   parse-                           installedPackageId     (\ipid pkg -> pkg{installedPackageId=ipid})- , simpleField "license"-                           disp                   parseLicenseQ-                           license                (\l pkg -> pkg{license=l})- , simpleField "copyright"-                           showFreeText           parseFreeText-                           copyright              (\val pkg -> pkg{copyright=val})- , simpleField "maintainer"-                           showFreeText           parseFreeText-                           maintainer             (\val pkg -> pkg{maintainer=val})- , simpleField "stability"-                           showFreeText           parseFreeText-                           stability              (\val pkg -> pkg{stability=val})- , simpleField "homepage"-                           showFreeText           parseFreeText-                           homepage               (\val pkg -> pkg{homepage=val})- , simpleField "package-url"-                           showFreeText           parseFreeText-                           pkgUrl                 (\val pkg -> pkg{pkgUrl=val})- , simpleField "synopsis"-                           showFreeText           parseFreeText-                           synopsis               (\val pkg -> pkg{synopsis=val})- , simpleField "description"-                           showFreeText           parseFreeText-                           description            (\val pkg -> pkg{description=val})- , simpleField "category"-                           showFreeText           parseFreeText-                           category               (\val pkg -> pkg{category=val})- , simpleField "author"-                           showFreeText           parseFreeText-                           author                 (\val pkg -> pkg{author=val})- ]--installedFieldDescrs :: [FieldDescr InstalledPackageInfo]-installedFieldDescrs = [-   boolField "exposed"-        exposed            (\val pkg -> pkg{exposed=val})- , listField   "exposed-modules"-        disp               parseModuleNameQ-        exposedModules     (\xs    pkg -> pkg{exposedModules=xs})- , listField   "hidden-modules"-        disp               parseModuleNameQ-        hiddenModules      (\xs    pkg -> pkg{hiddenModules=xs})- , boolField   "trusted"-        trusted            (\val pkg -> pkg{trusted=val})- , listField   "import-dirs"-        showFilePath       parseFilePathQ-        importDirs         (\xs pkg -> pkg{importDirs=xs})- , listField   "library-dirs"-        showFilePath       parseFilePathQ-        libraryDirs        (\xs pkg -> pkg{libraryDirs=xs})- , listField   "hs-libraries"-        showFilePath       parseTokenQ-        hsLibraries        (\xs pkg -> pkg{hsLibraries=xs})- , listField   "extra-libraries"-        showToken          parseTokenQ-        extraLibraries     (\xs pkg -> pkg{extraLibraries=xs})- , listField   "extra-ghci-libraries"-        showToken          parseTokenQ-        extraGHCiLibraries (\xs pkg -> pkg{extraGHCiLibraries=xs})- , listField   "include-dirs"-        showFilePath       parseFilePathQ-        includeDirs        (\xs pkg -> pkg{includeDirs=xs})- , listField   "includes"-        showFilePath       parseFilePathQ-        includes           (\xs pkg -> pkg{includes=xs})- , listField   "depends"-        disp               parse-        depends            (\xs pkg -> pkg{depends=xs})- , listField   "hugs-options"-        showToken          parseTokenQ-        hugsOptions        (\path  pkg -> pkg{hugsOptions=path})- , listField   "cc-options"-        showToken          parseTokenQ-        ccOptions          (\path  pkg -> pkg{ccOptions=path})- , listField   "ld-options"-        showToken          parseTokenQ-        ldOptions          (\path  pkg -> pkg{ldOptions=path})- , listField   "framework-dirs"-        showFilePath       parseFilePathQ-        frameworkDirs      (\xs pkg -> pkg{frameworkDirs=xs})- , listField   "frameworks"-        showToken          parseTokenQ-        frameworks         (\xs pkg -> pkg{frameworks=xs})- , listField   "haddock-interfaces"-        showFilePath       parseFilePathQ-        haddockInterfaces  (\xs pkg -> pkg{haddockInterfaces=xs})- , listField   "haddock-html"-        showFilePath       parseFilePathQ-        haddockHTMLs       (\xs pkg -> pkg{haddockHTMLs=xs})- ]
− Distribution/License.hs 
@@ -1,138 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.License--- Copyright   :  Isaac Jones 2003-2005---                Duncan Coutts 2008------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ The License datatype.  For more information about these and other--- open-source licenses, you may visit <http://www.opensource.org/>.------ The @.cabal@ file allows you to specify a license file. Of course you can--- use any license you like but people often pick common open source licenses--- and it's useful if we can automatically recognise that (eg so we can display--- it on the hackage web pages). So you can also specify the license itself in--- the @.cabal@ file from a short enumeration defined in this module. It--- includes 'GPL', 'LGPL' and 'BSD3' licenses.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.License (-    License(..),-    knownLicenses,-  ) where--import Distribution.Version (Version(Version))--import Distribution.Text (Text(..), display)-import qualified Distribution.Compat.ReadP as Parse-import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint ((<>))-import qualified Data.Char as Char (isAlphaNum)---- |This datatype indicates the license under which your package is--- released.  It is also wise to add your license to each source file--- using the license-file field.  The 'AllRightsReserved' constructor--- is not actually a license, but states that you are not giving--- anyone else a license to use or distribute your work.  The comments--- below are general guidelines.  Please read the licenses themselves--- and consult a lawyer if you are unsure of your rights to release--- the software.----data License =----TODO: * remove BSD4--    -- | GNU Public License. Source code must accompany alterations.-    GPL (Maybe Version)--    -- | Lesser GPL, Less restrictive than GPL, useful for libraries.-  | LGPL (Maybe Version)--    -- | 3-clause BSD license, newer, no advertising clause. Very free license.-  | BSD3--    -- | 4-clause BSD license, older, with advertising clause. You almost-    -- certainly want to use the BSD3 license instead.-  | BSD4--    -- | The MIT license, similar to the BSD3. Very free license.-  | MIT--    -- | Holder makes no claim to ownership, least restrictive license.-  | PublicDomain--    -- | No rights are granted to others. Undistributable. Most restrictive.-  | AllRightsReserved--    -- | Some other license.-  | OtherLicense--    -- | Not a recognised license.-    -- Allows us to deal with future extensions more gracefully.-  | UnknownLicense String-  deriving (Read, Show, Eq)--knownLicenses :: [License]-knownLicenses = [ GPL  unversioned, GPL  (version [2]),   GPL  (version [3])-                , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3])-                , BSD3, MIT-                , PublicDomain, AllRightsReserved, OtherLicense]- where-   unversioned = Nothing-   version   v = Just (Version v [])--instance Text License where-  disp (GPL  version)         = Disp.text "GPL"  <> dispOptVersion version-  disp (LGPL version)         = Disp.text "LGPL" <> dispOptVersion version-  disp (UnknownLicense other) = Disp.text other-  disp other                  = Disp.text (show other)--  parse = do-    name    <- Parse.munch1 (\c -> Char.isAlphaNum c && c /= '-')-    version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse)-    return $! case (name, version :: Maybe Version) of-      ("GPL",               _      ) -> GPL  version-      ("LGPL",              _      ) -> LGPL version-      ("BSD3",              Nothing) -> BSD3-      ("BSD4",              Nothing) -> BSD4-      ("MIT",               Nothing) -> MIT-      ("PublicDomain",      Nothing) -> PublicDomain-      ("AllRightsReserved", Nothing) -> AllRightsReserved-      ("OtherLicense",      Nothing) -> OtherLicense-      _                              -> UnknownLicense $ name-                                     ++ maybe "" (('-':) . display) version--dispOptVersion :: Maybe Version -> Disp.Doc-dispOptVersion Nothing  = Disp.empty-dispOptVersion (Just v) = Disp.char '-' <> disp v
− Distribution/Make.hs 
@@ -1,213 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Make--- Copyright   :  Martin Sj&#xF6;gren 2004------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This is an alternative build system that delegates everything to the @make@--- program. All the commands just end up calling @make@ with appropriate--- arguments. The intention was to allow preexisting packages that used--- makefiles to be wrapped into Cabal packages. In practice essentially all--- such packages were converted over to the \"Simple\" build system instead.--- Consequently this module is not used much and it certainly only sees cursory--- maintenance and no testing. Perhaps at some point we should stop pretending--- that it works.------ Uses the parsed command-line from "Distribution.Simple.Setup" in order to build--- Haskell tools using a backend build system based on make. Obviously we--- assume that there is a configure script, and that after the ConfigCmd has--- been run, there is a Makefile. Further assumptions:------ [ConfigCmd] We assume the configure script accepts---              @--with-hc@,---              @--with-hc-pkg@,---              @--prefix@,---              @--bindir@,---              @--libdir@,---              @--libexecdir@,---              @--datadir@.------ [BuildCmd] We assume that the default Makefile target will build everything.------ [InstallCmd] We assume there is an @install@ target. Note that we assume that--- this does *not* register the package!------ [CopyCmd]    We assume there is a @copy@ target, and a variable @$(destdir)@.---              The @copy@ target should probably just invoke @make install@---              recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix)---              bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make---              install@ directly here is that we don\'t know the value of @$(prefix)@.------ [SDistCmd] We assume there is a @dist@ target.------ [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@.------ [UnregisterCmd] We assume there is an @unregister@ target.------ [HaddockCmd] We assume there is a @docs@ or @doc@ target.-----                      copy :---                              $(MAKE) install prefix=$(destdir)/$(prefix) \---                                              bindir=$(destdir)/$(bindir) \--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Make (-        module Distribution.Package,-        License(..), Version(..),-        defaultMain, defaultMainArgs, defaultMainNoRead-  ) where---- local-import Distribution.Compat.Exception-import Distribution.Package --must not specify imports, since we're exporting moule.-import Distribution.Simple.Program(defaultProgramConfiguration)-import Distribution.PackageDescription-import Distribution.Simple.Setup-import Distribution.Simple.Command--import Distribution.Simple.Utils (rawSystemExit, cabalVersion)--import Distribution.License (License(..))-import Distribution.Version-         ( Version(..) )-import Distribution.Text-         ( display )--import System.Environment (getArgs, getProgName)-import Data.List  (intersperse)-import System.Exit--defaultMain :: IO ()-defaultMain = getArgs >>= defaultMainArgs--defaultMainArgs :: [String] -> IO ()-defaultMainArgs = defaultMainHelper--{-# DEPRECATED defaultMainNoRead "it ignores its PackageDescription arg" #-}-defaultMainNoRead :: PackageDescription -> IO ()-defaultMainNoRead = const defaultMain--defaultMainHelper :: [String] -> IO ()-defaultMainHelper args =-  case commandsRun globalCommand 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 (concat (intersperse "\n" errs))-      exitWith (ExitFailure 1)-    printNumericVersion = putStrLn $ display cabalVersion-    printVersion        = putStrLn $ "Cabal library version "-                                  ++ display cabalVersion--    progs = defaultProgramConfiguration-    commands =-      [configureCommand progs `commandAddAction` configureAction-      ,buildCommand     progs `commandAddAction` buildAction-      ,installCommand         `commandAddAction` installAction-      ,copyCommand            `commandAddAction` copyAction-      ,haddockCommand         `commandAddAction` haddockAction-      ,cleanCommand           `commandAddAction` cleanAction-      ,sdistCommand           `commandAddAction` sdistAction-      ,registerCommand        `commandAddAction` registerAction-      ,unregisterCommand      `commandAddAction` unregisterAction-      ]--configureAction :: ConfigFlags -> [String] -> IO ()-configureAction flags args = do-  noExtraFlags args-  let verbosity = fromFlag (configVerbosity flags)-  rawSystemExit verbosity "sh" $-    "configure"-    : configureArgs backwardsCompatHack flags-  where backwardsCompatHack = True--copyAction :: CopyFlags -> [String] -> IO ()-copyAction flags args = do-  noExtraFlags args-  let destArgs = case fromFlag $ copyDest flags of-        NoCopyDest      -> ["install"]-        CopyTo path     -> ["copy", "destdir=" ++ path]-  rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs--installAction :: InstallFlags -> [String] -> IO ()-installAction flags args = do-  noExtraFlags args-  rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"]-  rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"]--haddockAction :: HaddockFlags -> [String] -> IO ()-haddockAction flags args = do-  noExtraFlags args-  rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"]-    `catchIO` \_ ->-    rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"]--buildAction :: BuildFlags -> [String] -> IO ()-buildAction flags args = do-  noExtraFlags args-  rawSystemExit (fromFlag $ buildVerbosity flags) "make" []--cleanAction :: CleanFlags -> [String] -> IO ()-cleanAction flags args = do-  noExtraFlags args-  rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"]--sdistAction :: SDistFlags -> [String] -> IO ()-sdistAction flags args = do-  noExtraFlags args-  rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"]--registerAction :: RegisterFlags -> [String] -> IO ()-registerAction  flags args = do-  noExtraFlags args-  rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"]--unregisterAction :: RegisterFlags -> [String] -> IO ()-unregisterAction flags args = do-  noExtraFlags args-  rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"]
− Distribution/ModuleName.hs 
@@ -1,130 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.ModuleName--- Copyright   :  Duncan Coutts 2008------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Data type for Haskell module names.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.ModuleName (-        ModuleName,-        fromString,-        components,-        toFilePath,-        main,-        simple,-  ) where--import Distribution.Text-         ( Text(..) )--import qualified Distribution.Compat.ReadP as Parse-import qualified Text.PrettyPrint as Disp-import qualified Data.Char as Char-         ( isAlphaNum, isUpper )-import System.FilePath-         ( pathSeparator )-import Data.List-         ( intersperse )---- | A valid Haskell module name.----newtype ModuleName = ModuleName [String]-  deriving (Eq, Ord, Read, Show)--instance Text ModuleName where-  disp (ModuleName ms) =-    Disp.hcat (intersperse (Disp.char '.') (map Disp.text ms))--  parse = do-    ms <- Parse.sepBy1 component (Parse.char '.')-    return (ModuleName ms)--    where-      component = do-        c  <- Parse.satisfy Char.isUpper-        cs <- Parse.munch validModuleChar-        return (c:cs)--validModuleChar :: Char -> Bool-validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\''--validModuleComponent :: String -> Bool-validModuleComponent []     = False-validModuleComponent (c:cs) = Char.isUpper c-                           && all validModuleChar cs--{-# DEPRECATED simple "use ModuleName.fromString instead" #-}-simple :: String -> ModuleName-simple str = ModuleName [str]---- | 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.----fromString :: String -> ModuleName-fromString string-  | all validModuleComponent components' = ModuleName components'-  | otherwise                            = error badName--  where-    components' = split string-    badName     = "ModuleName.fromString: invalid module name " ++ show string--    split cs = case break (=='.') cs of-      (chunk,[])     -> chunk : []-      (chunk,_:rest) -> chunk : split rest---- | The module name @Main@.----main :: ModuleName-main = ModuleName ["Main"]---- | The individual components of a hierarchical module name. For example------ > components (fromString "A.B.C") = ["A", "B", "C"]----components :: ModuleName -> [String]-components (ModuleName ms) = ms---- | 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 = concat . intersperse [pathSeparator] . components
− Distribution/Package.hs 
@@ -1,193 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Package--- Copyright   :  Isaac Jones 2003-2004------ 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\"@.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Package (-        -- * Package ids-        PackageName(..),-        PackageIdentifier(..),-        PackageId,--        -- * Installed package identifiers-        InstalledPackageId(..),--        -- * Package source dependencies-        Dependency(..),-        thisPackageVersion,-        notThisPackageVersion,-        simplifyDependency,--        -- * Package classes-        Package(..), packageName, packageVersion,-        PackageFixedDeps(..),-  ) where--import Distribution.Version-         ( Version(..), VersionRange, anyVersion, thisVersion-         , notThisVersion, simplifyVersionRange )--import Distribution.Text (Text(..))-import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.ReadP ((<++))-import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint ((<>), (<+>), text)-import qualified Data.Char as Char ( isDigit, isAlphaNum )-import Data.List ( intersperse )--newtype PackageName = PackageName String-    deriving (Read, Show, Eq, Ord)--instance Text PackageName where-  disp (PackageName n) = Disp.text n-  parse = do-    ns <- Parse.sepBy1 component (Parse.char '-')-    return (PackageName (concat (intersperse "-" ns)))-    where-      component = do-        cs <- Parse.munch1 Char.isAlphaNum-        if all Char.isDigit cs then Parse.pfail else return cs-        -- each component must contain an alphabetic character, to avoid-        -- ambiguity in identifiers like foo-1 (the 1 is the version number).---- | 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 (Read, Show, Eq, Ord)--instance Text PackageIdentifier where-  disp (PackageIdentifier n v) = case v of-    Version [] _ -> disp n -- if no version, don't show version.-    _            -> disp n <> Disp.char '-' <> disp v--  parse = do-    n <- parse-    v <- (Parse.char '-' >> parse) <++ return (Version [] [])-    return (PackageIdentifier n v)---- --------------------------------------------------------------- * Installed Package Ids--- ---------------------------------------------------------------- | An InstalledPackageId uniquely identifies an instance of an installed package.--- There can be at most one package with a given 'InstalledPackageId'--- in a package database, or overlay of databases.----newtype InstalledPackageId = InstalledPackageId String- deriving (Read,Show,Eq,Ord)--instance Text InstalledPackageId where-  disp (InstalledPackageId str) = text str--  parse = InstalledPackageId `fmap` Parse.munch1 abi_char-   where abi_char c = Char.isAlphaNum c || c `elem` ":-_."---- --------------------------------------------------------------- * Package source dependencies--- ---------------------------------------------------------------- | Describes a dependency on a source package (API)----data Dependency = Dependency PackageName VersionRange-                  deriving (Read, Show, Eq)--instance Text Dependency where-  disp (Dependency name ver) =-    disp name <+> disp ver--  parse = do name <- parse-             Parse.skipSpaces-             ver <- parse <++ return anyVersion-             Parse.skipSpaces-             return (Dependency name ver)--thisPackageVersion :: PackageIdentifier -> Dependency-thisPackageVersion (PackageIdentifier n v) =-  Dependency n (thisVersion v)--notThisPackageVersion :: PackageIdentifier -> Dependency-notThisPackageVersion (PackageIdentifier n v) =-  Dependency n (notThisVersion v)---- | Simplify the 'VersionRange' expression in a 'Dependency'.--- See 'simplifyVersionRange'.----simplifyDependency :: Dependency -> Dependency-simplifyDependency (Dependency name range) =-  Dependency name (simplifyVersionRange range)---- | 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--packageName    :: Package pkg => pkg -> PackageName-packageName     = pkgName    . packageId--packageVersion :: Package pkg => pkg -> Version-packageVersion  = pkgVersion . packageId--instance Package PackageIdentifier where-  packageId = id---- | Subclass of packages that have specific versioned dependencies.------ So for example a not-yet-configured package has dependencies on version--- ranges, not specific versions. A configured or an already installed package--- depends on exact versions. Some operations or data structures (like---  dependency graphs) only make sense on this subclass of package types.----class Package pkg => PackageFixedDeps pkg where-  depends :: pkg -> [PackageIdentifier]
− Distribution/PackageDescription.hs 
@@ -1,1032 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription--- Copyright   :  Isaac Jones 2003-2005------ 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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.PackageDescription (-        -- * Package descriptions-        PackageDescription(..),-        emptyPackageDescription,-        specVersion,-        descCabalVersion,-        BuildType(..),-        knownBuildTypes,--        -- ** Libraries-        Library(..),-        emptyLibrary,-        withLib,-        hasLibs,-        libModules,--        -- ** Executables-        Executable(..),-        emptyExecutable,-        withExe,-        hasExes,-        exeModules,--        -- * Tests-        TestSuite(..),-        TestSuiteInterface(..),-        TestType(..),-        testType,-        knownTestTypes,-        emptyTestSuite,-        hasTests,-        withTest,-        testModules,-        enabledTests,--        -- * Benchmarks-        Benchmark(..),-        BenchmarkInterface(..),-        BenchmarkType(..),-        benchmarkType,-        knownBenchmarkTypes,-        emptyBenchmark,-        hasBenchmarks,-        withBenchmark,-        benchmarkModules,-        enabledBenchmarks,--        -- * Build information-        BuildInfo(..),-        emptyBuildInfo,-        allBuildInfo,-        allLanguages,-        allExtensions,-        usedExtensions,-        hcOptions,--        -- ** Supplementary build information-        HookedBuildInfo,-        emptyHookedBuildInfo,-        updatePackageDescription,--        -- * package configuration-        GenericPackageDescription(..),-        Flag(..), FlagName(..), FlagAssignment,-        CondTree(..), ConfVar(..), Condition(..),--        -- * Source repositories-        SourceRepo(..),-        RepoKind(..),-        RepoType(..),-        knownRepoTypes,-  ) where--import Data.List   (nub, intersperse)-import Data.Maybe  (maybeToList)-import Data.Monoid (Monoid(mempty, mappend))-import Control.Monad (MonadPlus(mplus))-import Text.PrettyPrint as Disp-import qualified Distribution.Compat.ReadP as Parse-import qualified Data.Char as Char (isAlphaNum, isDigit, toLower)--import Distribution.Package-         ( PackageName(PackageName), PackageIdentifier(PackageIdentifier)-         , Dependency, Package(..) )-import Distribution.ModuleName ( ModuleName )-import Distribution.Version-         ( Version(Version), VersionRange, anyVersion, orLaterVersion-         , asVersionIntervals, LowerBound(..) )-import Distribution.License  (License(AllRightsReserved))-import Distribution.Compiler (CompilerFlavor)-import Distribution.System   (OS, Arch)-import Distribution.Text-         ( Text(..), display )-import Language.Haskell.Extension-         ( Language, Extension )---- -------------------------------------------------------------------------------- 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:-        package        :: PackageIdentifier,-        license        :: License,-        licenseFile    :: FilePath,-        copyright      :: String,-        maintainer     :: String,-        author         :: String,-        stability      :: String,-        testedWith     :: [(CompilerFlavor,VersionRange)],-        homepage       :: String,-        pkgUrl         :: String,-        bugReports     :: String,-        sourceRepos    :: [SourceRepo],-        synopsis       :: String, -- ^A one-line summary of this package-        description    :: String, -- ^A more verbose description of this package-        category       :: String,-        customFieldsPD :: [(String,String)], -- ^Custom fields starting-                                             -- with x-, stored in a-                                             -- simple assoc-list.-        buildDepends   :: [Dependency],-        -- | The version of the Cabal spec that this package description uses.-        -- For historical reasons this is specified with a version range but-        -- only ranges of the form @>= v@ make sense. We are in the process of-        -- transitioning to specifying just a single version, not a range.-        specVersionRaw :: Either Version VersionRange,-        buildType      :: Maybe BuildType,-        -- components-        library        :: Maybe Library,-        executables    :: [Executable],-        testSuites     :: [TestSuite],-        benchmarks     :: [Benchmark],-        dataFiles      :: [FilePath],-        dataDir        :: FilePath,-        extraSrcFiles  :: [FilePath],-        extraTmpFiles  :: [FilePath]-    }-    deriving (Show, Read, Eq)--instance Package PackageDescription where-  packageId = package---- | The version of the Cabal spec that this package should be interpreted--- against.------ Historically we used a version range but we are switching to using a single--- version. Currently we accept either. This function converts into a single--- version by ignoring upper bounds in the version range.----specVersion :: PackageDescription -> Version-specVersion pkg = case specVersionRaw pkg of-  Left  version      -> version-  Right versionRange -> case asVersionIntervals versionRange of-                          []                            -> Version [0] []-                          ((LowerBound version _, _):_) -> version---- | The range of versions of the Cabal tools that this package is intended to--- work with.------ This function is deprecated and should not be used for new purposes, only to--- support old packages that rely on the old interpretation.----descCabalVersion :: PackageDescription -> VersionRange-descCabalVersion pkg = case specVersionRaw pkg of-  Left  version      -> orLaterVersion version-  Right versionRange -> versionRange-{-# DEPRECATED descCabalVersion "Use specVersion instead" #-}--emptyPackageDescription :: PackageDescription-emptyPackageDescription-    =  PackageDescription {-                      package      = PackageIdentifier (PackageName "")-                                                       (Version [] []),-                      license      = AllRightsReserved,-                      licenseFile  = "",-                      specVersionRaw = Right anyVersion,-                      buildType    = Nothing,-                      copyright    = "",-                      maintainer   = "",-                      author       = "",-                      stability    = "",-                      testedWith   = [],-                      buildDepends = [],-                      homepage     = "",-                      pkgUrl       = "",-                      bugReports   = "",-                      sourceRepos  = [],-                      synopsis     = "",-                      description  = "",-                      category     = "",-                      customFieldsPD = [],-                      library      = Nothing,-                      executables  = [],-                      testSuites   = [],-                      benchmarks   = [],-                      dataFiles    = [],-                      dataDir      = "",-                      extraSrcFiles = [],-                      extraTmpFiles = []-                     }---- | 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)-  | UnknownBuildType String-                -- ^ a package that uses an unknown build type cannot actually-                --   be built. Doing it this way rather than just giving a-                --   parse error means we get better error messages and allows-                --   you to inspect the rest of the package description.-                deriving (Show, Read, Eq)--knownBuildTypes :: [BuildType]-knownBuildTypes = [Simple, Configure, Make, Custom]--instance Text BuildType where-  disp (UnknownBuildType other) = Disp.text other-  disp other                    = Disp.text (show other)--  parse = do-    name <- Parse.munch1 Char.isAlphaNum-    return $ case name of-      "Simple"    -> Simple-      "Configure" -> Configure-      "Custom"    -> Custom-      "Make"      -> Make-      _           -> UnknownBuildType name---- ------------------------------------------------------------------------------ The Library type--data Library = Library {-        exposedModules    :: [ModuleName],-        libExposed        :: Bool, -- ^ Is the lib to be exposed by default?-        libBuildInfo      :: BuildInfo-    }-    deriving (Show, Eq, Read)--instance Monoid Library where-  mempty = Library {-    exposedModules = mempty,-    libExposed     = True,-    libBuildInfo   = mempty-  }-  mappend a b = Library {-    exposedModules = combine exposedModules,-    libExposed     = libExposed a && libExposed b, -- so False propagates-    libBuildInfo   = combine libBuildInfo-  }-    where combine field = field a `mappend` field b--emptyLibrary :: Library-emptyLibrary = mempty---- |does this package have any libraries?-hasLibs :: PackageDescription -> Bool-hasLibs p = maybe False (buildable . libBuildInfo) (library p)---- |'Maybe' version of 'hasLibs'-maybeHasLibs :: PackageDescription -> Maybe Library-maybeHasLibs p =-   library p >>= \lib -> if buildable (libBuildInfo lib)-                           then Just lib-                           else Nothing---- |If the package description has a library section, call the given---  function with the library build info as argument.-withLib :: PackageDescription -> (Library -> IO ()) -> IO ()-withLib pkg_descr f =-   maybe (return ()) f (maybeHasLibs pkg_descr)---- | Get all the module names from the library (exposed and internal modules)-libModules :: Library -> [ModuleName]-libModules lib = exposedModules lib-              ++ otherModules (libBuildInfo lib)---- ------------------------------------------------------------------------------ The Executable type--data Executable = Executable {-        exeName    :: String,-        modulePath :: FilePath,-        buildInfo  :: BuildInfo-    }-    deriving (Show, Read, Eq)--instance Monoid Executable where-  mempty = Executable {-    exeName    = mempty,-    modulePath = mempty,-    buildInfo  = mempty-  }-  mappend a b = Executable{-    exeName    = combine' exeName,-    modulePath = combine modulePath,-    buildInfo  = combine buildInfo-  }-    where combine field = field a `mappend` field b-          combine' field = case (field a, field b) of-                      ("","") -> ""-                      ("", x) -> x-                      (x, "") -> x-                      (x, y) -> error $ "Ambiguous values for executable field: '"-                                  ++ x ++ "' and '" ++ y ++ "'"--emptyExecutable :: Executable-emptyExecutable = mempty---- |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.-withExe :: PackageDescription -> (Executable -> IO ()) -> IO ()-withExe pkg_descr f =-  sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)]---- | Get all the module names from an exe-exeModules :: Executable -> [ModuleName]-exeModules exe = otherModules (buildInfo exe)---- ------------------------------------------------------------------------------ The TestSuite type---- | A \"test-suite\" stanza in a cabal file.----data TestSuite = TestSuite {-        testName      :: String,-        testInterface :: TestSuiteInterface,-        testBuildInfo :: BuildInfo,-        testEnabled   :: Bool-        -- TODO: By having a 'testEnabled' field in the PackageDescription, we-        -- are mixing build status information (i.e., arguments to 'configure')-        -- with static package description information. This is undesirable, but-        -- a better solution is waiting on the next overhaul to the-        -- GenericPackageDescription -> PackageDescription resolution process.-    }-    deriving (Show, Read, Eq)---- | 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, Read, Show)--instance Monoid TestSuite where-    mempty = TestSuite {-        testName      = mempty,-        testInterface = mempty,-        testBuildInfo = mempty,-        testEnabled   = False-    }--    mappend a b = TestSuite {-        testName      = combine' testName,-        testInterface = combine  testInterface,-        testBuildInfo = combine  testBuildInfo,-        testEnabled   = if testEnabled a then True else testEnabled b-    }-        where combine   field = field a `mappend` field b-              combine' f = case (f a, f b) of-                        ("", x) -> x-                        (x, "") -> x-                        (x, y) -> error "Ambiguous values for test field: '"-                            ++ x ++ "' and '" ++ y ++ "'"--instance Monoid TestSuiteInterface where-    mempty  =  TestSuiteUnsupported (TestTypeUnknown mempty (Version [] []))-    mappend a (TestSuiteUnsupported _) = a-    mappend _ b                        = b--emptyTestSuite :: TestSuite-emptyTestSuite = mempty---- | Does this package have any test suites?-hasTests :: PackageDescription -> Bool-hasTests = any (buildable . testBuildInfo) . testSuites---- | Get all the enabled test suites from a package.-enabledTests :: PackageDescription -> [TestSuite]-enabledTests = filter testEnabled . testSuites---- | Perform an action on each buildable 'TestSuite' in a package.-withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO ()-withTest pkg_descr f =-    mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr---- | Get all the module names from a test suite.-testModules :: TestSuite -> [ModuleName]-testModules test = (case testInterface test of-                     TestSuiteLibV09 _ m -> [m]-                     _                   -> [])-                ++ otherModules (testBuildInfo test)---- | 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 (Show, Read, Eq)--knownTestTypes :: [TestType]-knownTestTypes = [ TestTypeExe (Version [1,0] [])-                 , TestTypeLib (Version [0,9] []) ]--instance Text TestType where-  disp (TestTypeExe ver)          = text "exitcode-stdio-" <> disp ver-  disp (TestTypeLib ver)          = text "detailed-"       <> disp ver-  disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver--  parse = do-    cs   <- Parse.sepBy1 component (Parse.char '-')-    _    <- Parse.char '-'-    ver  <- parse-    let name = concat (intersperse "-" cs)-    return $! case lowercase name of-      "exitcode-stdio" -> TestTypeExe ver-      "detailed"       -> TestTypeLib ver-      _                -> TestTypeUnknown name ver--    where-      component = do-        cs <- Parse.munch1 Char.isAlphaNum-        if all Char.isDigit cs then Parse.pfail else return cs-        -- each component must contain an alphabetic character, to avoid-        -- ambiguity in identifiers like foo-1 (the 1 is the version number).--testType :: TestSuite -> TestType-testType test = case testInterface test of-  TestSuiteExeV10 ver _         -> TestTypeExe ver-  TestSuiteLibV09 ver _         -> TestTypeLib ver-  TestSuiteUnsupported testtype -> testtype---- ------------------------------------------------------------------------------ The Benchmark type---- | A \"benchmark\" stanza in a cabal file.----data Benchmark = Benchmark {-        benchmarkName      :: String,-        benchmarkInterface :: BenchmarkInterface,-        benchmarkBuildInfo :: BuildInfo,-        benchmarkEnabled   :: Bool-        -- TODO: See TODO for 'testEnabled'.-    }-    deriving (Show, Read, Eq)---- | 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, Read, Show)--instance Monoid Benchmark where-    mempty = Benchmark {-        benchmarkName      = mempty,-        benchmarkInterface = mempty,-        benchmarkBuildInfo = mempty,-        benchmarkEnabled   = False-    }--    mappend a b = Benchmark {-        benchmarkName      = combine' benchmarkName,-        benchmarkInterface = combine  benchmarkInterface,-        benchmarkBuildInfo = combine  benchmarkBuildInfo,-        benchmarkEnabled   = if benchmarkEnabled a then True-                             else benchmarkEnabled b-    }-        where combine   field = field a `mappend` field b-              combine' f = case (f a, f b) of-                        ("", x) -> x-                        (x, "") -> x-                        (x, y) -> error "Ambiguous values for benchmark field: '"-                            ++ x ++ "' and '" ++ y ++ "'"--instance Monoid BenchmarkInterface where-    mempty  =  BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] []))-    mappend a (BenchmarkUnsupported _) = a-    mappend _ b                        = b--emptyBenchmark :: Benchmark-emptyBenchmark = mempty---- | Does this package have any benchmarks?-hasBenchmarks :: PackageDescription -> Bool-hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks---- | Get all the enabled benchmarks from a package.-enabledBenchmarks :: PackageDescription -> [Benchmark]-enabledBenchmarks = filter benchmarkEnabled . benchmarks---- | Perform an action on each buildable 'Benchmark' in a package.-withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO ()-withBenchmark pkg_descr f =-    mapM_ f $ filter (buildable . benchmarkBuildInfo) $ enabledBenchmarks pkg_descr---- | Get all the module names from a benchmark.-benchmarkModules :: Benchmark -> [ModuleName]-benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark)---- | 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 (Show, Read, Eq)--knownBenchmarkTypes :: [BenchmarkType]-knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ]--instance Text BenchmarkType where-  disp (BenchmarkTypeExe ver)          = text "exitcode-stdio-" <> disp ver-  disp (BenchmarkTypeUnknown name ver) = text name <> char '-' <> disp ver--  parse = do-    cs   <- Parse.sepBy1 component (Parse.char '-')-    _    <- Parse.char '-'-    ver  <- parse-    let name = concat (intersperse "-" cs)-    return $! case lowercase name of-      "exitcode-stdio" -> BenchmarkTypeExe ver-      _                -> BenchmarkTypeUnknown name ver--    where-      component = do-        cs <- Parse.munch1 Char.isAlphaNum-        if all Char.isDigit cs then Parse.pfail else return cs-        -- each component must contain an alphabetic character, to avoid-        -- ambiguity in identifiers like foo-1 (the 1 is the version number).--benchmarkType :: Benchmark -> BenchmarkType-benchmarkType benchmark = case benchmarkInterface benchmark of-  BenchmarkExeV10 ver _              -> BenchmarkTypeExe ver-  BenchmarkUnsupported benchmarktype -> benchmarktype---- ------------------------------------------------------------------------------ The BuildInfo type---- Consider refactoring into executable and library versions.-data BuildInfo = BuildInfo {-        buildable         :: Bool,      -- ^ component is buildable here-        buildTools        :: [Dependency], -- ^ tools needed to build this bit-        cppOptions        :: [String],  -- ^ options for pre-processing Haskell code-        ccOptions         :: [String],  -- ^ options for C compiler-        ldOptions         :: [String],  -- ^ options for linker-        pkgconfigDepends  :: [Dependency], -- ^ pkg-config packages that are used-        frameworks        :: [String], -- ^support frameworks for Mac OS X-        cSources          :: [FilePath],-        hsSourceDirs      :: [FilePath], -- ^ where to look for the haskell module hierarchy-        otherModules      :: [ModuleName], -- ^ non-exposed or non-main modules--        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-        extraLibDirs      :: [String],-        includeDirs       :: [FilePath], -- ^directories to find .h files-        includes          :: [FilePath], -- ^ The .h files to be found in includeDirs-        installIncludes   :: [FilePath], -- ^ .h files to install with the package-        options           :: [(CompilerFlavor,[String])],-        ghcProfOptions    :: [String],-        ghcSharedOptions  :: [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-    }-    deriving (Show,Read,Eq)--instance Monoid BuildInfo where-  mempty = BuildInfo {-    buildable         = True,-    buildTools        = [],-    cppOptions        = [],-    ccOptions         = [],-    ldOptions         = [],-    pkgconfigDepends  = [],-    frameworks        = [],-    cSources          = [],-    hsSourceDirs      = [],-    otherModules      = [],-    defaultLanguage   = Nothing,-    otherLanguages    = [],-    defaultExtensions = [],-    otherExtensions   = [],-    oldExtensions     = [],-    extraLibs         = [],-    extraLibDirs      = [],-    includeDirs       = [],-    includes          = [],-    installIncludes   = [],-    options           = [],-    ghcProfOptions    = [],-    ghcSharedOptions  = [],-    customFieldsBI    = [],-    targetBuildDepends = []-  }-  mappend a b = BuildInfo {-    buildable         = buildable a && buildable b,-    buildTools        = combine    buildTools,-    cppOptions        = combine    cppOptions,-    ccOptions         = combine    ccOptions,-    ldOptions         = combine    ldOptions,-    pkgconfigDepends  = combine    pkgconfigDepends,-    frameworks        = combineNub frameworks,-    cSources          = combineNub cSources,-    hsSourceDirs      = combineNub hsSourceDirs,-    otherModules      = combineNub otherModules,-    defaultLanguage   = combineMby defaultLanguage,-    otherLanguages    = combineNub otherLanguages,-    defaultExtensions = combineNub defaultExtensions,-    otherExtensions   = combineNub otherExtensions,-    oldExtensions     = combineNub oldExtensions,-    extraLibs         = combine    extraLibs,-    extraLibDirs      = combineNub extraLibDirs,-    includeDirs       = combineNub includeDirs,-    includes          = combineNub includes,-    installIncludes   = combineNub installIncludes,-    options           = combine    options,-    ghcProfOptions    = combine    ghcProfOptions,-    ghcSharedOptions  = combine    ghcSharedOptions,-    customFieldsBI    = combine    customFieldsBI,-    targetBuildDepends = combineNub targetBuildDepends-  }-    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 'BuildInfo' for the library (if there is one and it's buildable), and--- all buildable executables, test suites and benchmarks.  Useful for gathering--- dependencies.-allBuildInfo :: PackageDescription -> [BuildInfo]-allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr]-                              , let bi = libBuildInfo lib-                              , buildable bi ]-                      ++ [ bi | exe <- executables pkg_descr-                              , let bi = buildInfo exe-                              , buildable bi ]-                      ++ [ bi | tst <- testSuites pkg_descr-                              , let bi = testBuildInfo tst-                              , buildable bi-                              , testEnabled tst ]-                      ++ [ bi | tst <- benchmarks pkg_descr-                              , let bi = benchmarkBuildInfo tst-                              , buildable bi-                              , benchmarkEnabled tst ]-  --FIXME: many of the places where this is used, we actually want to look at-  --       unbuildable bits too, probably need separate functions---- | 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--type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)])--emptyHookedBuildInfo :: HookedBuildInfo-emptyHookedBuildInfo = (Nothing, [])---- |Select options for a particular Haskell compiler.-hcOptions :: CompilerFlavor -> BuildInfo -> [String]-hcOptions hc bi = [ opt | (hc',opts) <- options bi-                        , hc' == hc-                        , opt <- opts ]---- --------------------------------------------------------------- * 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, Read, Show)---- | 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, Ord, Read, Show)---- | 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 RepoType = Darcs | Git | SVN | CVS-              | Mercurial | GnuArch | Bazaar | Monotone-              | OtherRepoType String-  deriving (Eq, Ord, Read, Show)--knownRepoTypes :: [RepoType]-knownRepoTypes = [Darcs, Git, SVN, CVS-                 ,Mercurial, GnuArch, Bazaar, Monotone]--repoTypeAliases :: RepoType -> [String]-repoTypeAliases Bazaar    = ["bzr"]-repoTypeAliases Mercurial = ["hg"]-repoTypeAliases GnuArch   = ["arch"]-repoTypeAliases _         = []--instance Text RepoKind where-  disp RepoHead                = Disp.text "head"-  disp RepoThis                = Disp.text "this"-  disp (RepoKindUnknown other) = Disp.text other--  parse = do-    name <- ident-    return $ case lowercase name of-      "head" -> RepoHead-      "this" -> RepoThis-      _      -> RepoKindUnknown name--instance Text RepoType where-  disp (OtherRepoType other) = Disp.text other-  disp other                 = Disp.text (lowercase (show other))-  parse = fmap classifyRepoType ident--classifyRepoType :: String -> RepoType-classifyRepoType s =-  case lookup (lowercase s) repoTypeMap of-    Just repoType' -> repoType'-    Nothing        -> OtherRepoType s-  where-    repoTypeMap = [ (name, repoType')-                  | repoType' <- knownRepoTypes-                  , name <- display repoType' : repoTypeAliases repoType' ]--ident :: Parse.ReadP r String-ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')--lowercase :: String -> String-lowercase = map Char.toLower---- --------------------------------------------------------------- * Utils--- --------------------------------------------------------------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 :: [(String, 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 :: (String, BuildInfo) -- ^(exeName, new buildinfo)-                       -> [Executable]        -- ^list of executables to update-                       -> [Executable]        -- ^libst 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---- ------------------------------------------------------------------------------ The GenericPackageDescription type--data GenericPackageDescription =-    GenericPackageDescription {-        packageDescription :: PackageDescription,-        genPackageFlags       :: [Flag],-        condLibrary        :: Maybe (CondTree ConfVar [Dependency] Library),-        condExecutables    :: [(String, CondTree ConfVar [Dependency] Executable)],-        condTestSuites     :: [(String, CondTree ConfVar [Dependency] TestSuite)],-        condBenchmarks     :: [(String, CondTree ConfVar [Dependency] Benchmark)]-      }-    deriving (Show, Eq)--instance Package GenericPackageDescription where-  packageId = packageId . packageDescription----TODO: make PackageDescription an instance of Text.---- | 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 Flag = MkFlag-    { flagName        :: FlagName-    , flagDescription :: String-    , flagDefault     :: Bool-    , flagManual      :: Bool-    }-    deriving (Show, Eq)---- | A 'FlagName' is the name of a user-defined configuration flag-newtype FlagName = FlagName String-    deriving (Eq, Ord, Show, Read)---- | 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)]@----type FlagAssignment = [(FlagName, Bool)]---- | A @ConfVar@ represents the variable type used.-data ConfVar = OS OS-             | Arch Arch-             | Flag FlagName-             | Impl CompilerFlavor VersionRange-    deriving (Eq, Show)----instance Text ConfVar where---    disp (OS os) = "os(" ++ display os ++ ")"---    disp (Arch arch) = "arch(" ++ display arch ++ ")"---    disp (Flag (ConfFlag f)) = "flag(" ++ f ++ ")"---    disp (Impl c v) = "impl(" ++ display c---                       ++ " " ++ display v ++ ")"---- | 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)----instance Text c => Text (Condition c) where---  disp (Var x) = text (show x)---  disp (Lit b) = text (show b)---  disp (CNot c) = char '!' <> parens (ppCond c)---  disp (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2]---  disp (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2]--data CondTree v c a = CondNode-    { condTreeData        :: a-    , condTreeConstraints :: c-    , condTreeComponents  :: [( Condition v-                              , CondTree v c a-                              , Maybe (CondTree v c a))]-    }-    deriving (Show, Eq)----instance (Text v, Text c) => Text (CondTree v c a) where---  disp (CondNode _dat cs ifs) =---    (text "build-depends: " <+>---      disp cs)---    $+$---    (vcat $ map ppIf ifs)---  where---    ppIf (c,thenTree,mElseTree) =---        ((text "if" <+> ppCond c <> colon) $$---          nest 2 (ppCondTree thenTree disp))---        $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t disp))---                   mElseTree)
− Distribution/PackageDescription/Check.hs 
@@ -1,1477 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription.Check--- Copyright   :  Lennart Kolmodin 2008------ 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 check so we can see which ones are appropriate to report--- in different situations. This code gets uses when configuring a package when--- we consider only basic problems. The higher standard is uses when 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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.PackageDescription.Check (-        -- * Package Checking-        PackageCheck(..),-        checkPackage,-        checkConfiguredPackage,--        -- ** Checking package contents-        checkPackageFiles,-        checkPackageContent,-        CheckPackageContentOps(..),-        checkPackageFileNames,-  ) where--import Data.Maybe-         ( isNothing, isJust, catMaybes, maybeToList, fromMaybe )-import Data.List  (sort, group, isPrefixOf, nub, find)-import Control.Monad-         ( filterM, liftM )-import qualified System.Directory as System-         ( doesFileExist, doesDirectoryExist )--import Distribution.Package ( pkgName )-import Distribution.PackageDescription-import Distribution.PackageDescription.Configuration-         ( flattenPackageDescription, finalizePackageDescription )-import Distribution.Compiler-         ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..) )-import Distribution.System-         ( OS(..), Arch(..), buildPlatform )-import Distribution.License-         ( License(..), knownLicenses )-import Distribution.Simple.Utils-         ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase )--import Distribution.Version-         ( Version(..)-         , VersionRange(..), foldVersionRange'-         , anyVersion, noVersion, thisVersion, laterVersion, earlierVersion-         , orLaterVersion, orEarlierVersion-         , unionVersionRanges, intersectVersionRanges-         , asVersionIntervals, UpperBound(..), isNoVersion )-import Distribution.Package-         ( PackageName(PackageName), packageName, packageVersion-         , Dependency(..) )--import Distribution.Text-         ( display, disp )-import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint ((<>), (<+>))--import qualified Language.Haskell.Extension as Extension (deprecatedExtensions)-import Language.Haskell.Extension-         ( Language(UnknownLanguage), knownLanguages, Extension(..), KnownExtension(..) )-import System.FilePath-         ( (</>), takeExtension, isRelative, isAbsolute-         , splitDirectories,  splitPath )-import System.FilePath.Windows as FilePath.Windows-         ( isValid )---- | 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 determental 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 }--       -- | 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 }--instance Show PackageCheck where-    show notice = explanation notice--check :: Bool -> PackageCheck -> Maybe PackageCheck-check False _  = Nothing-check True  pc = Just pc---- --------------------------------------------------------------- * Standard checks--- ---------------------------------------------------------------- | Check for common mistakes and problems in package descriptions.------ This is the standard collection of checks covering all apsects 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-  where-    pkg = fromMaybe (flattenPackageDescription gpkg) mpkg----TODO: make this variant go away---      we should alwaws know the GenericPackageDescription-checkConfiguredPackage :: PackageDescription -> [PackageCheck]-checkConfiguredPackage pkg =-    checkSanity pkg- ++ checkFields pkg- ++ checkLicense pkg- ++ checkSourceRepos pkg- ++ checkGhcOptions pkg- ++ checkCCOptions pkg- ++ checkPaths pkg- ++ checkCabalVersion pkg----- --------------------------------------------------------------- * Basic sanity checks--- ---------------------------------------------------------------- | Check that this package description is sane.----checkSanity :: PackageDescription -> [PackageCheck]-checkSanity pkg =-  catMaybes [--    check (null . (\(PackageName n) -> n) . packageName $ pkg) $-      PackageBuildImpossible "No 'name' field."--  , check (null . versionBranch . packageVersion $ pkg) $-      PackageBuildImpossible "No 'version' field."--  , check (null (executables pkg) && isNothing (library pkg)) $-      PackageBuildImpossible-        "No executables and no library found. Nothing to do."--  , check (not (null duplicateNames)) $-      PackageBuildImpossible $ "Duplicate sections: " ++ commaSep duplicateNames-        ++ ". The name of every executable, test suite, and benchmark section in"-        ++ " the package must be unique."-  ]-  --TODO: check for name clashes case insensitively: windows file systems cannot cope.--  ++ maybe []  checkLibrary    (library pkg)-  ++ concatMap checkExecutable (executables pkg)-  ++ concatMap (checkTestSuite pkg) (testSuites pkg)-  ++ concatMap (checkBenchmark pkg) (benchmarks pkg)--  ++ catMaybes [--    check (specVersion pkg > cabalVersion) $-      PackageBuildImpossible $-           "This package description follows version "-        ++ display (specVersion pkg) ++ " of the Cabal specification. This "-        ++ "tool only supports up to version " ++ display cabalVersion ++ "."-  ]-  where-    exeNames = map exeName $ executables pkg-    testNames = map testName $ testSuites pkg-    bmNames = map benchmarkName $ benchmarks pkg-    duplicateNames = dups $ exeNames ++ testNames ++ bmNames--checkLibrary :: Library -> [PackageCheck]-checkLibrary lib =-  catMaybes [--    check (not (null moduleDuplicates)) $-       PackageBuildWarning $-            "Duplicate modules in library: "-         ++ commaSep (map display moduleDuplicates)-  ]--  where-    moduleDuplicates = dups (libModules lib)--checkExecutable :: Executable -> [PackageCheck]-checkExecutable exe =-  catMaybes [--    check (null (modulePath exe)) $-      PackageBuildImpossible $-        "No 'Main-Is' field found for executable " ++ exeName exe--  , check (not (null (modulePath exe))-       && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $-      PackageBuildImpossible $-           "The 'Main-Is' field must specify a '.hs' or '.lhs' file "-        ++ "(even if it is generated by a preprocessor)."--  , check (not (null moduleDuplicates)) $-       PackageBuildWarning $-            "Duplicate modules in executable '" ++ exeName exe ++ "': "-         ++ commaSep (map display moduleDuplicates)-  ]-  where-    moduleDuplicates = dups (exeModules exe)--checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck]-checkTestSuite pkg test =-  catMaybes [--    case testInterface test of-      TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $-        PackageBuildWarning $-             quote (display tt) ++ " is not a known type of test suite. "-          ++ "The known test suite types are: "-          ++ commaSep (map display knownTestTypes)--      TestSuiteUnsupported tt -> Just $-        PackageBuildWarning $-             quote (display tt) ++ " is not a supported test suite version. "-          ++ "The known test suite types are: "-          ++ commaSep (map display knownTestTypes)-      _ -> Nothing--  , check (not $ null moduleDuplicates) $-      PackageBuildWarning $-           "Duplicate modules in test suite '" ++ testName test ++ "': "-        ++ commaSep (map display moduleDuplicates)--  , check mainIsWrongExt $-      PackageBuildImpossible $-           "The 'main-is' field must specify a '.hs' or '.lhs' file "-        ++ "(even if it is generated by a preprocessor)."--    -- Test suites might be built as (internal) libraries named after-    -- the test suite and thus their names must not clash with the-    -- name of the package.-  , check libNameClash $-      PackageBuildImpossible $-           "The test suite " ++ testName test-        ++ " has the same name as the package."-  ]-  where-    moduleDuplicates = dups $ testModules test--    mainIsWrongExt = case testInterface test of-      TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]-      _                   -> False--    libNameClash = testName test `elem` [ libName-                                        | _lib <- maybeToList (library pkg)-                                        , let PackageName libName =-                                                pkgName (package pkg) ]--checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck]-checkBenchmark pkg bm =-  catMaybes [--    case benchmarkInterface bm of-      BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $-        PackageBuildWarning $-             quote (display tt) ++ " is not a known type of benchmark. "-          ++ "The known benchmark types are: "-          ++ commaSep (map display knownBenchmarkTypes)--      BenchmarkUnsupported tt -> Just $-        PackageBuildWarning $-             quote (display tt) ++ " is not a supported benchmark version. "-          ++ "The known benchmark types are: "-          ++ commaSep (map display knownBenchmarkTypes)-      _ -> Nothing--  , check (not $ null moduleDuplicates) $-      PackageBuildWarning $-           "Duplicate modules in benchmark '" ++ benchmarkName bm ++ "': "-        ++ commaSep (map display moduleDuplicates)--  , check mainIsWrongExt $-      PackageBuildImpossible $-           "The 'main-is' field must specify a '.hs' or '.lhs' file "-        ++ "(even if it is generated by a preprocessor)."--    -- See comment for similar check on test suites.-  , check libNameClash $-      PackageBuildImpossible $-           "The benchmark " ++ benchmarkName bm-        ++ " has the same name as the package."-  ]-  where-    moduleDuplicates = dups $ benchmarkModules bm--    mainIsWrongExt = case benchmarkInterface bm of-      BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]-      _                   -> False--    libNameClash = benchmarkName bm `elem` [ libName-                                           | _lib <- maybeToList (library pkg)-                                           , let PackageName libName =-                                                   pkgName (package pkg) ]---- --------------------------------------------------------------- * Additional pure checks--- --------------------------------------------------------------checkFields :: PackageDescription -> [PackageCheck]-checkFields pkg =-  catMaybes [--    check (not . FilePath.Windows.isValid . display . packageName $ pkg) $-      PackageDistInexcusable $-           "Unfortunately, the package name '" ++ display (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 (isNothing (buildType pkg)) $-      PackageBuildWarning $-           "No 'build-type' specified. If you do not need a custom Setup.hs or "-        ++ "./configure script then use 'build-type: Simple'."--  , case buildType pkg of-      Just (UnknownBuildType unknown) -> Just $-        PackageBuildWarning $-             quote unknown ++ " is not a known 'build-type'. "-          ++ "The known build types are: "-          ++ commaSep (map display knownBuildTypes)-      _ -> Nothing--  , 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 deprecatedExtensions)) $-      PackageDistSuspicious $-           "Deprecated extensions: "-        ++ commaSep (map (quote . display . fst) deprecatedExtensions)-        ++ ". " ++ intercalate " "-             [ "Instead of '" ++ display ext-            ++ "' use '" ++ display replacement ++ "'."-             | (ext, Just replacement) <- deprecatedExtensions ]--  , check (null (category pkg)) $-      PackageDistSuspicious "No 'category' field."--  , check (null (maintainer pkg)) $-      PackageDistSuspicious "No 'maintainer' field."--  , check (null (synopsis pkg) && null (description pkg)) $-      PackageDistInexcusable $ "No 'synopsis' or 'description' field."--  , check (null (description pkg) && not (null (synopsis pkg))) $-      PackageDistSuspicious "No 'description' field."--  , check (null (synopsis pkg) && not (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 (length (synopsis pkg) >= 80) $-      PackageDistSuspicious-        "The 'synopsis' field is rather long (max 80 chars is recommended)."--    -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12"-  , check (not (null testedWithImpossibleRanges)) $-      PackageDistInexcusable $-           "Invalid 'tested-with' version range: "-        ++ commaSep (map display 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'."-  ]-  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 display knownLanguages ]-    deprecatedExtensions = nub $ catMaybes-      [ find ((==ext) . fst) Extension.deprecatedExtensions-      | bi <- allBuildInfo pkg-      , ext <- allExtensions bi ]-    languagesUsedAsExtensions =-      [ name | bi <- allBuildInfo pkg-             , UnknownExtension name <- allExtensions bi-             , name `elem` map display knownLanguages ]--    testedWithImpossibleRanges =-      [ Dependency (PackageName (display compiler)) vr-      | (compiler, vr) <- testedWith pkg-      , isNoVersion vr ]---checkLicense :: PackageDescription -> [PackageCheck]-checkLicense pkg =-  catMaybes [--    check (license pkg == AllRightsReserved) $-      PackageDistInexcusable-        "The 'license' field is missing or specified as AllRightsReserved."--  , case license pkg of-      UnknownLicense l -> Just $-        PackageBuildWarning $-             quote ("license: " ++ l) ++ " is not a recognised license. The "-          ++ "known licenses are: "-          ++ commaSep (map display knownLicenses)-      _ -> Nothing--  , check (license pkg == 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 (license pkg) of-      Just knownVersions -> Just $-        PackageDistSuspicious $-             "'license: " ++ display (license pkg) ++ "' is not a known "-          ++ "version of that license. The known versions are "-          ++ commaSep (map display knownVersions)-          ++ ". If this is not a mistake and you think it should be a known "-          ++ "version then please file a ticket."-      _ -> Nothing--  , check (license pkg `notElem` [AllRightsReserved, PublicDomain]-           -- AllRightsReserved and PublicDomain are not strictly-           -- licenses so don't need license files.-        && null (licenseFile 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 _ = Nothing--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 (repoType repo == Nothing) $-      PackageDistInexcusable-        "The source-repository 'type' is a required field."--  , check (repoLocation repo == Nothing) $-      PackageDistInexcusable-        "The source-repository 'location' is a required field."--  , check (repoType repo == Just CVS && repoModule repo == Nothing) $-      PackageDistInexcusable-        "For a CVS source-repository, the 'module' is a required field."--  , check (repoKind repo == RepoThis && repoTag repo == Nothing) $-      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 System.FilePath.isAbsolute (repoSubdir repo)) $-      PackageDistInexcusable-        "The 'subdir' field of a source-repository must be a relative path."-  ]-  | repo <- sourceRepos pkg ]----TODO: check location looks like a URL for some repo types.--checkGhcOptions :: PackageDescription -> [PackageCheck]-checkGhcOptions pkg =-  catMaybes [--    check has_WerrorWall $-      PackageDistInexcusable $-           "'ghc-options: -Wall -Werror' makes the package very easy to "-        ++ "break with future GHC versions because new GHC versions often "-        ++ "add new warnings. Use just 'ghc-options: -Wall' instead."--  , check (not has_WerrorWall && has_Werror) $-      PackageDistSuspicious $-           "'ghc-options: -Werror' makes the package easy to "-        ++ "break with future GHC versions because new GHC versions often "-        ++ "add new warnings."--  , checkFlags ["-fasm"] $-      PackageDistInexcusable $-           "'ghc-options: -fasm' is unnecessary and will not work on CPU "-        ++ "architectures other than x86, x86-64, ppc or sparc."--  , checkFlags ["-fvia-C"] $-      PackageDistSuspicious $-           "'ghc-options: -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 $-        "'ghc-options: -fhpc' is not appropriate for a distributed package."--  , check (any ("-d" `isPrefixOf`) all_ghc_options) $-      PackageDistInexcusable $-        "'ghc-options: -d*' debug flags are not appropriate for a distributed package."--  , checkFlags ["-prof"] $-      PackageBuildWarning $-           "'ghc-options: -prof' is not necessary and will lead to problems "-        ++ "when used on a library. Use the configure flag "-        ++ "--enable-library-profiling and/or --enable-executable-profiling."--  , checkFlags ["-o"] $-      PackageBuildWarning $-        "'ghc-options: -o' is not needed. The output files are named automatically."--  , checkFlags ["-hide-package"] $-      PackageBuildWarning $-           "'ghc-options: -hide-package' is never needed. Cabal hides all packages."--  , checkFlags ["--make"] $-      PackageBuildWarning $-        "'ghc-options: --make' is never needed. Cabal uses this automatically."--  , checkFlags ["-main-is"] $-      PackageDistSuspicious $-           "'ghc-options: -main-is' is not portable."--  , checkFlags ["-O0", "-Onot"] $-      PackageDistSuspicious $-        "'ghc-options: -O0' is not needed. Use the --disable-optimization configure flag."--  , checkFlags [ "-O", "-O1"] $-      PackageDistInexcusable $-           "'ghc-options: -O' is not needed. Cabal automatically adds the '-O' flag. "-        ++ "Setting it yourself interferes with the --disable-optimization flag."--  , checkFlags ["-O2"] $-      PackageDistSuspicious $-           "'ghc-options: -O2' is rarely needed. Check that it is giving a real benefit "-        ++ "and not just imposing longer compile times on your users."--  , checkFlags ["-split-objs"] $-      PackageBuildWarning $-        "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag."--  , checkFlags ["-optl-Wl,-s", "-optl-s"] $-      PackageDistInexcusable $-           "'ghc-options: -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 'ghc-options: -fglasgow-exts' it is preferable to use the 'extensions' field."--  , check ("-threaded" `elem` lib_ghc_options) $-      PackageDistSuspicious $-           "'ghc-options: -threaded' has no effect for libraries. It should "-        ++ "only be used for executables."--  , checkAlternatives "ghc-options" "extensions"-      [ (flag, display extension) | flag <- all_ghc_options-                                  , Just extension <- [ghcExtension flag] ]--  , checkAlternatives "ghc-options" "extensions"-      [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ]--  , checkAlternatives "ghc-options" "cpp-options" $-         [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ]-      ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ]--  , checkAlternatives "ghc-options" "include-dirs"-      [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ]--  , checkAlternatives "ghc-options" "extra-libraries"-      [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ]--  , checkAlternatives "ghc-options" "extra-lib-dirs"-      [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ]-  ]--  where-    has_WerrorWall = flip any ghc_options $ \opts ->-                               "-Werror" `elem` opts-                           && ("-Wall"   `elem` opts || "-W" `elem` opts)-    has_Werror     = any (\opts -> "-Werror" `elem` opts) ghc_options--    ghc_options = [ strs | bi <- allBuildInfo pkg-                         , (GHC, strs) <- options bi ]-    all_ghc_options = concat ghc_options-    lib_ghc_options = maybe [] (hcOptions GHC . libBuildInfo) (library pkg)--    checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck-    checkFlags flags = check (any (`elem` flags) all_ghc_options)--    ghcExtension ('-':'f':name) = case name of-      "allow-overlapping-instances"    -> Just (EnableExtension  OverlappingInstances)-      "no-allow-overlapping-instances" -> Just (DisableExtension OverlappingInstances)-      "th"                             -> Just (EnableExtension  TemplateHaskell)-      "no-th"                          -> Just (DisableExtension TemplateHaskell)-      "ffi"                            -> Just (EnableExtension  ForeignFunctionInterface)-      "no-ffi"                         -> Just (DisableExtension ForeignFunctionInterface)-      "fi"                             -> Just (EnableExtension  ForeignFunctionInterface)-      "no-fi"                          -> Just (DisableExtension ForeignFunctionInterface)-      "monomorphism-restriction"       -> Just (EnableExtension  MonomorphismRestriction)-      "no-monomorphism-restriction"    -> Just (DisableExtension MonomorphismRestriction)-      "mono-pat-binds"                 -> Just (EnableExtension  MonoPatBinds)-      "no-mono-pat-binds"              -> Just (DisableExtension MonoPatBinds)-      "allow-undecidable-instances"    -> Just (EnableExtension  UndecidableInstances)-      "no-allow-undecidable-instances" -> Just (DisableExtension UndecidableInstances)-      "allow-incoherent-instances"     -> Just (EnableExtension  IncoherentInstances)-      "no-allow-incoherent-instances"  -> Just (DisableExtension IncoherentInstances)-      "arrows"                         -> Just (EnableExtension  Arrows)-      "no-arrows"                      -> Just (DisableExtension Arrows)-      "generics"                       -> Just (EnableExtension  Generics)-      "no-generics"                    -> Just (DisableExtension Generics)-      "implicit-prelude"               -> Just (EnableExtension  ImplicitPrelude)-      "no-implicit-prelude"            -> Just (DisableExtension ImplicitPrelude)-      "implicit-params"                -> Just (EnableExtension  ImplicitParams)-      "no-implicit-params"             -> Just (DisableExtension ImplicitParams)-      "bang-patterns"                  -> Just (EnableExtension  BangPatterns)-      "no-bang-patterns"               -> Just (DisableExtension BangPatterns)-      "scoped-type-variables"          -> Just (EnableExtension  ScopedTypeVariables)-      "no-scoped-type-variables"       -> Just (DisableExtension ScopedTypeVariables)-      "extended-default-rules"         -> Just (EnableExtension  ExtendedDefaultRules)-      "no-extended-default-rules"      -> Just (DisableExtension ExtendedDefaultRules)-      _                                -> Nothing-    ghcExtension "-cpp"             = Just (EnableExtension CPP)-    ghcExtension _                  = Nothing--checkCCOptions :: PackageDescription -> [PackageCheck]-checkCCOptions pkg =-  catMaybes [--    checkAlternatives "cc-options" "include-dirs"-      [ (flag, dir) | flag@('-':'I':dir) <- all_ccOptions ]--  , checkAlternatives "cc-options" "extra-libraries"-      [ (flag, lib) | flag@('-':'l':lib) <- all_ccOptions ]--  , checkAlternatives "cc-options" "extra-lib-dirs"-      [ (flag, dir) | flag@('-':'L':dir) <- all_ccOptions ]--  , 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 $-           "'cc-options: -O[n]' is generally not needed. When building with "-        ++ " optimisations Cabal automatically adds '-O2' for C code. "-        ++ "Setting it yourself interferes with the --disable-optimization "-        ++ "flag."-  ]--  where all_ccOptions = [ opts | bi <- allBuildInfo pkg-                              , opts <- ccOptions bi ]-        all_ldOptions = [ opts | bi <- allBuildInfo pkg-                               , opts <- ldOptions bi ]--        checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck-        checkCCFlags flags = check (any (`elem` flags) all_ccOptions)--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--checkPaths :: PackageDescription -> [PackageCheck]-checkPaths pkg =-  [ PackageBuildWarning $-         quote (kind ++ ": " ++ path)-      ++ " is a relative path outside of the source tree. "-      ++ "This will not work when generating a tarball with 'sdist'."-  | (path, kind) <- relPaths ++ absPaths-  , isOutsideTree path ]-  ++-  [ PackageDistInexcusable $-      quote (kind ++ ": " ++ path) ++ " is an absolute directory."-  | (path, kind) <- relPaths-  , isAbsolute path ]-  ++-  [ PackageDistInexcusable $-         quote (kind ++ ": " ++ 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, kind) <- 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) <- options bi-  , path <- flags-  , isInsideDist path ]-  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 =-         [ (path, "extra-src-files") | path <- extraSrcFiles pkg ]-      ++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ]-      ++ [ (path, "data-files")      | path <- dataFiles     pkg ]-      ++ [ (path, "data-dir")        | path <- [dataDir      pkg]]-      ++ concat-         [    [ (path, "c-sources")        | path <- cSources        bi ]-           ++ [ (path, "install-includes") | path <- installIncludes bi ]-           ++ [ (path, "hs-source-dirs")   | path <- hsSourceDirs    bi ]-         | bi <- allBuildInfo pkg ]-    -- paths that are allowed to be absolute-    absPaths = concat-      [    [ (path, "includes")         | path <- includes        bi ]-        ++ [ (path, "include-dirs")     | path <- includeDirs     bi ]-        ++ [ (path, "extra-lib-dirs")   | 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 syntax of cabal-version field-    check (specVersion pkg >= Version [1,10] []-           && not simpleSpecVersionRangeSyntax) $-      PackageBuildWarning $-           "Packages relying on Cabal 1.10 or later must only specify a "-        ++ "version range of the form 'cabal-version: >= x.y'. Use "-        ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'."--    -- check syntax of cabal-version field-  , check (specVersion pkg < Version [1,9] []-           && not simpleSpecVersionRangeSyntax) $-      PackageDistSuspicious $-           "It is recommended that the 'cabal-version' field only specify a "-        ++ "version range of the form '>= x.y'. Use "-        ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'. "-        ++ "Tools based on Cabal 1.10 and later will ignore upper bounds."--    -- check syntax of cabal-version field-  , checkVersion [1,12] simpleSpecVersionSyntax $-      PackageBuildWarning $-           "With Cabal 1.10 or earlier, the 'cabal-version' field must use "-        ++ "range syntax rather than a simple version number. Use "-        ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'."--    -- check use of test suite sections-  , checkVersion [1,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 [1,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 >= Version [1,10] []-           && (any isNothing (buildInfoField defaultLanguage))) $-      PackageBuildWarning $-           "Packages using 'cabal-version: >= 1.10' 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."--    -- check use of default-extensions field-    -- don't need to do the equivalent check for other-extensions-  , checkVersion [1,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 >= Version [1,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."--    -- check use of "foo (>= 1.0 && < 1.4) || >=1.8 " version-range syntax-  , checkVersion [1,8] (not (null versionRangeExpressions)) $-      PackageDistInexcusable $-           "The package uses full version-range expressions "-        ++ "in a 'build-depends' field: "-        ++ commaSep (map displayRawDependency versionRangeExpressions)-        ++ ". To use this new syntax the package needs to specify at least "-        ++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility "-        ++ "is important, then convert to conjunctive normal form, and use "-        ++ "multiple 'build-depends:' lines, one conjunct per line."--    -- check use of "build-depends: foo == 1.*" syntax-  , checkVersion [1,6] (not (null depsUsingWildcardSyntax)) $-      PackageDistInexcusable $-           "The package uses wildcard syntax in the 'build-depends' field: "-        ++ commaSep (map display depsUsingWildcardSyntax)-        ++ ". To use this new syntax the package need to specify at least "-        ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability "-        ++ "is important then use: " ++ commaSep-           [ display (Dependency name (eliminateWildcardSyntax versionRange))-           | Dependency name versionRange <- depsUsingWildcardSyntax ]--    -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax-  , checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $-      PackageDistInexcusable $-           "The package uses full version-range expressions "-        ++ "in a 'tested-with' field: "-        ++ commaSep (map displayRawDependency testedWithVersionRangeExpressions)-        ++ ". To use this new syntax the package needs to specify at least "-        ++ "'cabal-version: >= 1.8'."--    -- check use of "tested-with: GHC == 6.12.*" syntax-  , checkVersion [1,6] (not (null testedWithUsingWildcardSyntax)) $-      PackageDistInexcusable $-           "The package uses wildcard syntax in the 'tested-with' field: "-        ++ commaSep (map display testedWithUsingWildcardSyntax)-        ++ ". To use this new syntax the package need to specify at least "-        ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability "-        ++ "is important then use: " ++ commaSep-           [ display (Dependency name (eliminateWildcardSyntax versionRange))-           | Dependency name versionRange <- testedWithUsingWildcardSyntax ]--    -- check use of "data-files: data/*.txt" syntax-  , checkVersion [1,6] (not (null dataFilesUsingGlobSyntax)) $-      PackageDistInexcusable $-           "Using wildcards like "-        ++ commaSep (map quote $ take 3 dataFilesUsingGlobSyntax)-        ++ " in the 'data-files' field requires 'cabal-version: >= 1.6'. "-        ++ "Alternatively if you require compatability with earlier Cabal "-        ++ "versions then list all the files explicitly."--    -- check use of "extra-source-files: mk/*.in" syntax-  , checkVersion [1,6] (not (null extraSrcFilesUsingGlobSyntax)) $-      PackageDistInexcusable $-           "Using wildcards like "-        ++ commaSep (map quote $ take 3 extraSrcFilesUsingGlobSyntax)-        ++ " in the 'extra-source-files' field requires "-        ++ "'cabal-version: >= 1.6'. Alternatively if you require "-        ++ "compatability with earlier Cabal versions then list all the files "-        ++ "explicitly."--    -- check use of "source-repository" section-  , checkVersion [1,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 licenses-  , checkVersion [1,4] (license pkg `notElem` compatLicenses) $-      PackageDistInexcusable $-           "Unfortunately the license " ++ quote (display (license pkg))-        ++ " messes up the parser in earlier Cabal versions so you need to "-        ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "-        ++ "compatability with earlier Cabal versions then use 'OtherLicense'."--    -- check for new language extensions-  , checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $-      PackageDistInexcusable $-           "Unfortunately the language extensions "-        ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal12)-        ++ " break the parser in earlier Cabal versions so you need to "-        ++ "specify 'cabal-version: >= 1.2.3'. Alternatively if you require "-        ++ "compatability with earlier Cabal versions then you may be able to "-        ++ "use an equivalent compiler-specific flag."--  , checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $-      PackageDistInexcusable $-           "Unfortunately the language extensions "-        ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal14)-        ++ " break the parser in earlier Cabal versions so you need to "-        ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "-        ++ "compatability with earlier Cabal versions then you may be able to "-        ++ "use an equivalent compiler-specific flag."-  ]-  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 :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck-    checkVersion ver cond pc-      | specVersion pkg >= Version ver []      = Nothing-      | otherwise                              = check cond pc--    buildInfoField field         = map field (allBuildInfo pkg)-    dataFilesUsingGlobSyntax     = filter usesGlobSyntax (dataFiles pkg)-    extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg)-    usesGlobSyntax str = case parseFileGlob str of-      Just (FileGlob _ _) -> True-      _                   -> False--    versionRangeExpressions =-        [ dep | dep@(Dependency _ vr) <- buildDepends pkg-              , usesNewVersionRangeSyntax vr ]--    testedWithVersionRangeExpressions =-        [ Dependency (PackageName (display compiler)) vr-        | (compiler, vr) <- testedWith pkg-        , usesNewVersionRangeSyntax vr ]--    simpleSpecVersionRangeSyntax =-        either (const True)-               (foldVersionRange'-                      True-                      (\_ -> False)-                      (\_ -> False) (\_ -> False)-                      (\_ -> True)  -- >=-                      (\_ -> False)-                      (\_ _ -> False)-                      (\_ _ -> False) (\_ _ -> False)-                      id)-               (specVersionRaw pkg)--    -- is the cabal-version field a simple version number, rather than a range-    simpleSpecVersionSyntax =-      either (const True) (const False) (specVersionRaw pkg)--    usesNewVersionRangeSyntax :: VersionRange -> Bool-    usesNewVersionRangeSyntax =-        (> 2) -- uses the new syntax if depth is more than 2-      . foldVersionRange'-          (1 :: Int)-          (const 1)-          (const 1) (const 1)-          (const 1) (const 1)-          (const (const 1))-          (+) (+)-          (const 3) -- uses new ()'s syntax--    depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg-                                    , usesWildcardSyntax vr ]--    testedWithUsingWildcardSyntax = [ Dependency (PackageName (display compiler)) vr-                                    | (compiler, vr) <- testedWith pkg-                                    , usesWildcardSyntax vr ]--    usesWildcardSyntax :: VersionRange -> Bool-    usesWildcardSyntax =-      foldVersionRange'-        False (const False)-        (const False) (const False)-        (const False) (const False)-        (\_ _ -> True) -- the wildcard case-        (||) (||) id--    eliminateWildcardSyntax =-      foldVersionRange'-        anyVersion thisVersion-        laterVersion earlierVersion-        orLaterVersion orEarlierVersion-        (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v'))-        intersectVersionRanges unionVersionRanges id--    compatLicenses = [ GPL Nothing, LGPL Nothing, BSD3, BSD4-                     , PublicDomain, AllRightsReserved, OtherLicense ]--    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]---- | A variation on the normal 'Text' instance, shows any ()'s in the original--- textual syntax. We need to show these otherwise it's confusing to users when--- we complain of their presense but do not pretty print them!----displayRawVersionRange :: VersionRange -> String-displayRawVersionRange =-   Disp.render- . fst- . foldVersionRange'                         -- precedence:-     -- All the same as the usual pretty printer, except for the parens-     (         Disp.text "-any"                           , 0 :: Int)-     (\v   -> (Disp.text "==" <> disp v                   , 0))-     (\v   -> (Disp.char '>'  <> disp v                   , 0))-     (\v   -> (Disp.char '<'  <> disp v                   , 0))-     (\v   -> (Disp.text ">=" <> disp v                   , 0))-     (\v   -> (Disp.text "<=" <> disp v                   , 0))-     (\v _ -> (Disp.text "==" <> dispWild v               , 0))-     (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2))-     (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1))-     (\(r,  _ )          -> (Disp.parens r, 0)) -- parens--  where-    dispWild (Version b _) =-           Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))-        <> Disp.text ".*"-    punct p p' | p < p'    = Disp.parens-               | otherwise = id--displayRawDependency :: Dependency -> String-displayRawDependency (Dependency pkg vr) =-  display pkg ++ " " ++ displayRawVersionRange vr----- --------------------------------------------------------------- * Checks on the GenericPackageDescription--- ---------------------------------------------------------------- | Check the build-depends fields for any weirdness or bad practise.----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 practise "-        ++ "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 2 and 3 then use 'build-depends: base >= 2 && < 4'."--  ]-  where-    -- TODO: What we really want to do is test if there exists any-    -- configuration in which the base version is unboudned 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 = finalizePackageDescription-                              [] (const True) buildPlatform-                              (CompilerId buildCompilerFlavor (Version [] []))-                              [] pkg-    baseDependency = case finalised of-      Right (pkg', _) | not (null baseDeps) ->-          foldr intersectVersionRanges anyVersion baseDeps-        where-          baseDeps =-            [ vr | Dependency (PackageName "base") vr <- buildDepends pkg' ]--      -- Just in case finalizePackageDescription 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--    boundedAbove :: VersionRange -> Bool-    boundedAbove vr = case asVersionIntervals vr of-      []        -> True -- this is the inconsistent version range.-      intervals -> case last intervals of-        (_,   UpperBound _ _) -> True-        (_, 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 = maybe [] freeVars (condLibrary pkg)-              ++ concatMap (freeVars . snd) (condExecutables pkg)-    freeVars (CondNode _ _ ifs) = concatMap compfv ifs-    compfv (c, ct, mct) = condfv c ++ freeVars ct ++ maybe [] freeVars 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---- --------------------------------------------------------------- * 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 filepath.----checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck]-checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg-  where-    checkFilesIO = CheckPackageContentOps {-      doesFileExist      = System.doesFileExist      . relative,-      doesDirectoryExist = System.doesDirectoryExist . 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-  }---- | 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-                    -> PackageDescription-                    -> m [PackageCheck]-checkPackageContent ops pkg = do-  licenseError    <- checkLicenseExists   ops pkg-  setupError      <- checkSetupExists     ops pkg-  configureError  <- checkConfigureExists ops pkg-  localPathErrors <- checkLocalPathsExist ops pkg-  vcsLocation     <- checkMissingVcsInfo  ops pkg--  return $ catMaybes [licenseError, setupError, configureError]-        ++ localPathErrors-        ++ vcsLocation--checkLicenseExists :: Monad m => CheckPackageContentOps m-                   -> PackageDescription-                   -> m (Maybe PackageCheck)-checkLicenseExists ops pkg-  | null (licenseFile pkg) = return Nothing-  | otherwise = do-    exists <- doesFileExist ops file-    return $ check (not exists) $-      PackageBuildWarning $-           "The 'license-file' field refers to the file " ++ quote file-        ++ " which does not exist."--  where-    file = licenseFile pkg--checkSetupExists :: Monad m => CheckPackageContentOps m-                 -> PackageDescription-                 -> m (Maybe PackageCheck)-checkSetupExists ops _ = do-  hsexists  <- doesFileExist ops "Setup.hs"-  lhsexists <- doesFileExist ops "Setup.lhs"-  return $ check (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 PackageDescription { buildType = Just Configure } = do-  exists <- doesFileExist ops "configure"-  return $ check (not exists) $-    PackageBuildWarning $-      "The 'build-type' is 'Configure' but there is no 'configure' script."-checkConfigureExists _ _ = 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, "include-dirs")   | dir <- includeDirs  bi ]-               ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ]-             , isRelative 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 => CheckPackageContentOps m-                    -> PackageDescription-                    -> m [PackageCheck]-checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do-    vcsInUse <- liftM or $ mapM (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 :: RepoType -> [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 _          = []---- --------------------------------------------------------------- * 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 . catMaybes . map checkWindowsPath $ files)-  ++ (take 1 . catMaybes . map 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 (first:rest) -> case pack prefixMax remainder of-      Left err         -> Just err-      Right []         -> Nothing-      Right (_:_)      -> Just noSplit-     where-        -- drop the '/' between the name and prefix:-        remainder = init first : 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."---- --------------------------------------------------------------- * Utils--- --------------------------------------------------------------quote :: String -> String-quote s = "'" ++ s ++ "'"--commaSep :: [String] -> String-commaSep = intercalate ", "--dups :: Ord a => [a] -> [a]-dups xs = [ x | (x:_:_) <- group (sort xs) ]
− Distribution/PackageDescription/Configuration.hs 
@@ -1,652 +0,0 @@-{-# OPTIONS -cpp #-}--- OPTIONS required for ghc-6.4.x compat, and must appear first-{-# LANGUAGE CPP #-}--- -fno-warn-deprecations for use of Map.foldWithKey-{-# OPTIONS_GHC -cpp -fno-warn-deprecations #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Configuration--- Copyright   :  Thomas Schilling, 2007------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This is about the cabal configurations feature. It exports--- 'finalizePackageDescription' 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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.PackageDescription.Configuration (-    finalizePackageDescription,-    flattenPackageDescription,--    -- Utils-    parseCondition,-    freeVars,-    mapCondTree,-    mapTreeData,-    mapTreeConds,-    mapTreeConstrs,-  ) where--import Distribution.Package-         ( PackageName, Dependency(..) )-import Distribution.PackageDescription-         ( GenericPackageDescription(..), PackageDescription(..)-         , Library(..), Executable(..), BuildInfo(..)-         , Flag(..), FlagName(..), FlagAssignment-         , Benchmark(..), CondTree(..), ConfVar(..), Condition(..)-         , TestSuite(..) )-import Distribution.Version-         ( VersionRange, anyVersion, intersectVersionRanges, withinRange )-import Distribution.Compiler-         ( CompilerId(CompilerId) )-import Distribution.System-         ( Platform(..), OS, Arch )-import Distribution.Simple.Utils-         ( currentDir, lowercase )--import Distribution.Text-         ( Text(parse) )-import Distribution.Compat.ReadP as ReadP hiding ( char )-import Control.Arrow (first)-import qualified Distribution.Compat.ReadP as ReadP ( char )--import Data.Char ( isAlphaNum )-import Data.Maybe ( catMaybes, maybeToList )-import Data.Map ( Map, fromListWith, toList )-import qualified Data.Map as Map-import Data.Monoid--#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606)-import qualified Text.Read as R-import qualified Text.Read.Lex as L-#endif------------------------------------------------------------------------------------ | 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---- | Simplify a configuration condition using the os and arch names.  Returns---   the names of all the flags occurring in the condition.-simplifyWithSysParams :: OS -> Arch -> CompilerId -> Condition ConfVar-                      -> (Condition FlagName, [FlagName])-simplifyWithSysParams os arch (CompilerId comp compVer) 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) = Right $ comp' == comp-                                  && compVer `withinRange` vr-    interp (Flag  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 :: ReadP r (Condition ConfVar)-parseCondition = condOr-  where-    condOr   = sepBy1 condAnd (oper "||") >>= return . foldl1 COr-    condAnd  = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd-    cond     = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond-                      +++ archCond +++ flagCond +++ implCond )-    inparens   = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp)-    notCond  = ReadP.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  parse-    archIdent     = fmap Arch parse-    osIdent       = fmap OS   parse-    flagIdent     = fmap (Flag . FlagName . lowercase) (munch1 isIdentChar)-    isIdentChar c = isAlphaNum c || c == '_' || c == '-'-    oper s        = sp >> string s >> sp-    sp            = skipSpaces-    implIdent     = do i <- parse-                       vr <- sp >> option anyVersion parse-                       return $ Impl i vr----------------------------------------------------------------------------------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 (cnd, t, me) = (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---- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for---   clarity.-data DepTestRslt d = DepOk | MissingDeps d--instance Monoid d => Monoid (DepTestRslt d) where-    mempty = DepOk-    mappend DepOk x = x-    mappend x DepOk = x-    mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d')---data BT a = BTN a | BTB (BT a) (BT a)  -- very simple binary tree----- | Try to find a flag assignment that satisfies the constaints 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 _smallest_ number of of missing dependencies 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.-  -> OS      -- ^ OS as returned by Distribution.System.buildOS-  -> Arch    -- ^ Arch as returned by Distribution.System.buildArch-  -> CompilerId -- ^ Compiler flavour + version-  -> [Dependency]  -- ^ 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 os arch impl constrs trees checkDeps =-    case try dom [] of-      Right r -> Right r-      Left dbt -> Left $ findShortest dbt-  where-    extraConstrs = toDepMap constrs--    -- simplify trees by (partially) evaluating all conditions and converting-    -- dependencies to dependency maps.-    simplifiedTrees = map ( mapTreeConstrs toDepMap  -- convert to maps-                          . mapTreeConds (fst . simplifyWithSysParams os arch impl))-                          trees--    -- @try@ recursively tries all possible flag assignments in the domain and-    -- either succeeds or returns a binary tree with the missing dependencies-    -- encountered in each run.  Since the tree is constructed lazily, we-    -- avoid some computation overhead in the successful case.-    try [] flags =-        let targetSet = TargetSet $ flip map simplifiedTrees $-                -- apply additional constraints to all dependencies-                first (`constrainBy` extraConstrs) .-                simplifyCondTree (env flags)-            deps = overallDependencies targetSet-        in case checkDeps (fromDepMap deps) of-             DepOk           -> Right (targetSet, flags)-             MissingDeps mds -> Left (BTN mds)--    try ((n, vals):rest) flags =-        tryAll $ map (\v -> try rest ((n, v):flags)) vals--    tryAll = foldr mp mz--    -- special version of `mplus' for our local purposes-    mp (Left xs)   (Left ys)   = (Left (BTB xs ys))-    mp (Left _)    m@(Right _) = m-    mp m@(Right _) _           = m--    -- `mzero'-    mz = Left (BTN [])--    env flags flag = (maybe (Left flag) Right . lookup flag) flags--    -- for the error case we inspect our lazy tree of missing dependencies and-    -- pick the shortest list of missing dependencies-    findShortest (BTN x) = x-    findShortest (BTB lt rt) =-        let l = findShortest lt-            r = findShortest rt-        in case (l,r) of-             ([], xs) -> xs  -- [] is too short-             (xs, []) -> xs-             ([x], _) -> [x] -- single elem is optimum-             (_, [x]) -> [x]-             (xs, ys) -> if lazyLengthCmp xs ys-                         then xs else ys-    -- lazy variant of @\xs ys -> length xs <= length ys@-    lazyLengthCmp [] _ = True-    lazyLengthCmp _ [] = False-    lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys---- | 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 }-#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606)-  deriving (Show, Read)-#else--- The Show/Read instance for Data.Map in ghc-6.4 is useless--- so we have to re-implement it here:-instance Show DependencyMap where-  showsPrec d (DependencyMap m) =-      showParen (d > 10) (showString "DependencyMap" . shows (M.toList m))--instance Read DependencyMap where-  readPrec = parens $ R.prec 10 $ do-    R.Ident "DependencyMap" <- R.lexP-    xs <- R.readPrec-    return (DependencyMap (M.fromList xs))-      where parens :: R.ReadPrec a -> R.ReadPrec a-            parens p = optional-             where-               optional  = p R.+++ mandatory-               mandatory = paren optional--            paren :: R.ReadPrec a -> R.ReadPrec a-            paren p = do L.Punc "(" <- R.lexP-                         x          <- R.reset p-                         L.Punc ")" <- R.lexP-                         return x--  readListPrec = R.readListPrecDefault-#endif--instance Monoid DependencyMap where-    mempty = DependencyMap Map.empty-    (DependencyMap a) `mappend` (DependencyMap b) =-        DependencyMap (Map.unionWith intersectVersionRanges a b)--toDepMap :: [Dependency] -> DependencyMap-toDepMap ds =-  DependencyMap $ fromListWith intersectVersionRanges [ (p,vr) | Dependency p vr <- ds ]--fromDepMap :: DependencyMap -> [Dependency]-fromDepMap m = [ Dependency p vr | (p,vr) <- toList (unDependencyMap m) ]--simplifyCondTree :: (Monoid a, Monoid d) =>-                    (v -> Either v Bool)-                 -> CondTree v d a-                 -> (d, a)-simplifyCondTree env (CondNode a d ifs) =-    foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs-  where-    simplifyIf (cnd, t, me) =-        case simplifyCondition cnd env of-          (Lit True, _) -> Just $ simplifyCondTree env t-          (Lit False, _) -> fmap (simplifyCondTree env) me-          _ -> error $ "Environment not defined for all free vars"---- | 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 :: (Monoid a, Monoid c) => CondTree v c a -> (a, c)-ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs)-  where f (_, t, me) = ignoreConditions t-                       : maybeToList (fmap ignoreConditions me)--freeVars :: CondTree ConfVar c a  -> [FlagName]-freeVars t = [ f | Flag f <- freeVars' t ]-  where-    freeVars' (CondNode _ _ ifs) = concatMap compfv ifs-    compfv (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 :: TargetSet PDTagged -> DependencyMap-overallDependencies (TargetSet targets) = mconcat depss-  where-    (depss, _) = unzip $ filter (removeDisabledSections . snd) targets-    removeDisabledSections :: PDTagged -> Bool-    removeDisabledSections (Lib _) = True-    removeDisabledSections (Exe _ _) = True-    removeDisabledSections (Test _ t) = testEnabled t-    removeDisabledSections (Bench _ b) = benchmarkEnabled b-    removeDisabledSections PDNull = True---- 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  -- ^ Input map-            -> DependencyMap  -- ^ Extra constraints-            -> DependencyMap-constrainBy left extra =-    DependencyMap $-      Map.foldWithKey tightenConstraint (unDependencyMap left)-                                        (unDependencyMap extra)-  where tightenConstraint n c l =-            case Map.lookup n l of-              Nothing -> l-              Just vr -> Map.insert n (intersectVersionRanges vr c) l---- | Collect up the targets in a TargetSet of tagged targets, storing the--- dependencies as we go.-flattenTaggedTargets :: TargetSet PDTagged ->-        (Maybe Library, [(String, Executable)], [(String, TestSuite)]-        , [(String, Benchmark)])-flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], []) targets-  where-    untag (_, Lib _) (Just _, _, _, _) = bug "Only one library expected"-    untag (deps, Lib l) (Nothing, exes, tests, bms) =-        (Just l', exes, tests, bms)-      where-        l' = l {-                libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }-            }-    untag (deps, Exe n e) (mlib, exes, tests, bms)-        | any ((== n) . fst) exes = bug "Exe with same name found"-        | any ((== n) . fst) tests = bug "Test sharing name of exe found"-        | any ((== n) . fst) bms = bug "Benchmark sharing name of exe found"-        | otherwise = (mlib, exes ++ [(n, e')], tests, bms)-      where-        e' = e {-                buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }-            }-    untag (deps, Test n t) (mlib, exes, tests, bms)-        | any ((== n) . fst) tests = bug "Test with same name found"-        | any ((== n) . fst) exes = bug "Test sharing name of exe found"-        | any ((== n) . fst) bms = bug "Test sharing name of benchmark found"-        | otherwise = (mlib, exes, tests ++ [(n, t')], bms)-      where-        t' = t {-            testBuildInfo = (testBuildInfo t)-                { targetBuildDepends = fromDepMap deps }-            }-    untag (deps, Bench n b) (mlib, exes, tests, bms)-        | any ((== n) . fst) bms = bug "Benchmark with same name found"-        | any ((== n) . fst) exes = bug "Benchmark sharing name of exe found"-        | any ((== n) . fst) tests = bug "Benchmark sharing name of test found"-        | otherwise = (mlib, exes, tests, bms ++ [(n, b')])-      where-        b' = b {-            benchmarkBuildInfo = (benchmarkBuildInfo b)-                { targetBuildDepends = fromDepMap deps }-            }-    untag (_, PDNull) x = x  -- actually this should not happen, but let's be liberal------------------------------------------------------------------------------------ Convert GenericPackageDescription to PackageDescription-----data PDTagged = Lib Library-              | Exe String Executable-              | Test String TestSuite-              | Bench String Benchmark-              | PDNull-              deriving Show--instance Monoid PDTagged where-    mempty = PDNull-    PDNull `mappend` x = x-    x `mappend` PDNull = x-    Lib l `mappend` Lib l' = Lib (l `mappend` l')-    Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e')-    Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t')-    Bench n b `mappend` Bench n' b' | n == n' = Bench n (b `mappend` b')-    _ `mappend` _ = bug "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 a /minimum/--- number of dependencies that could not be satisfied.  On success, it will--- return the package description and the full flag assignment chosen.----finalizePackageDescription ::-     FlagAssignment  -- ^ Explicitly specified flag assignments-  -> (Dependency -> Bool) -- ^ Is a given depenency satisfiable from the set of available packages?-                          -- If this is unknown then use True.-  -> Platform      -- ^ The 'Arch' and 'OS'-  -> CompilerId    -- ^ Compiler + Version-  -> [Dependency]  -- ^ Additional constraints-  -> GenericPackageDescription-  -> Either [Dependency]-            (PackageDescription, FlagAssignment)-             -- ^ Either missing dependencies or the resolved package-             -- description along with the flag assignments chosen.-finalizePackageDescription userflags satisfyDep (Platform arch os) impl constraints-        (GenericPackageDescription pkg flags mlib0 exes0 tests0 bms0) =-    case resolveFlags of-      Right ((mlib, exes', tests', bms'), targetSet, flagVals) ->-        Right ( pkg { library = mlib-                    , executables = exes'-                    , testSuites = tests'-                    , benchmarks = bms'-                    , buildDepends = fromDepMap (overallDependencies targetSet)-                      --TODO: we need to find a way to avoid pulling in deps-                      -- for non-buildable components. However cannot simply-                      -- filter at this stage, since if the package were not-                      -- available we would have failed already.-                    }-              , flagVals )--      Left missing -> Left missing-  where-    -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data-    condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 )-                ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0-                ++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0-                ++ map (\(name,tree) -> mapTreeData (Bench name) tree) bms0--    resolveFlags =-        case resolveWithFlags flagChoices os arch impl constraints condTrees check of-          Right (targetSet, fs) ->-              let (mlib, exes, tests, bms) = flattenTaggedTargets targetSet in-              Right ( (fmap libFillInDefaults mlib,-                       map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes,-                       map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests,-                       map (\(n,b) -> (benchFillInDefaults b) { benchmarkName = n }) bms),-                     targetSet, fs)-          Left missing      -> Left missing--    flagChoices    = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags-    d2c manual n b = case lookup n userflags of-                     Just val -> [val]-                     Nothing-                      | manual -> [b]-                      | otherwise -> [b, not b]-    --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices-    check ds     = if all satisfyDep ds-                   then DepOk-                   else MissingDeps $ filter (not . satisfyDep) ds--{--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 exes0 tests0 bms0) =-    pkg { library = mlib-        , executables = reverse exes-        , testSuites = reverse tests-        , benchmarks = reverse bms-        , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps ++ reverse bdeps-        }-  where-    (mlib, ldeps) = case mlib0 of-        Just lib -> let (l,ds) = ignoreConditions lib in-                    (Just (libFillInDefaults l), ds)-        Nothing -> (Nothing, [])-    (exes, edeps) = foldr flattenExe ([],[]) exes0-    (tests, tdeps) = foldr flattenTst ([],[]) tests0-    (bms, bdeps) = foldr flattenBm ([],[]) bms0-    flattenExe (n, t) (es, ds) =-        let (e, ds') = ignoreConditions t in-        ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds )-    flattenTst (n, t) (es, ds) =-        let (e, ds') = ignoreConditions t in-        ( (testFillInDefaults $ e { testName = n }) : es, ds' ++ ds )-    flattenBm (n, t) (es, ds) =-        let (e, ds') = ignoreConditions t in-        ( (benchFillInDefaults $ e { benchmarkName = n }) : es, ds' ++ ds )---- 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 }--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 = [currentDir] }-    else bi--bug :: String -> a-bug msg = error $ msg ++ ". Consider this a bug."
− Distribution/PackageDescription/Parse.hs 
@@ -1,1203 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription.Parse--- Copyright   :  Isaac Jones 2003-2005------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This defined parsers and partial pretty printers for the @.cabal@ format.--- Some of the complexity in this module is due to the fact that we have to be--- backwards compatible with old @.cabal@ files, so there's code to translate--- into the newer structure.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.PackageDescription.Parse (-        -- * Package descriptions-        readPackageDescription,-        writePackageDescription,-        parsePackageDescription,-        showPackageDescription,--        -- ** Parsing-        ParseResult(..),-        FieldDescr(..),-        LineNo,--        -- ** Supplementary build information-        readHookedBuildInfo,-        parseHookedBuildInfo,-        writeHookedBuildInfo,-        showHookedBuildInfo,--        pkgDescrFieldDescrs,-        libFieldDescrs,-        executableFieldDescrs,-        binfoFieldDescrs,-        sourceRepoFieldDescrs,-        testSuiteFieldDescrs,-        flagFieldDescrs-  ) where--import Data.Char  (isSpace)-import Data.Maybe (listToMaybe, isJust)-import Data.Monoid ( Monoid(..) )-import Data.List  (nub, unfoldr, partition, (\\))-import Control.Monad (liftM, foldM, when, unless)-import System.Directory (doesFileExist)--import Distribution.Text-         ( Text(disp, parse), display, simpleParse )-import Distribution.Compat.ReadP-         ((+++), option)-import Text.PrettyPrint--import Distribution.ParseUtils hiding (parseFields)-import Distribution.PackageDescription-import Distribution.Package-         ( PackageIdentifier(..), Dependency(..), packageName, packageVersion )-import Distribution.ModuleName ( ModuleName )-import Distribution.Version-        ( Version(Version), orLaterVersion-        , LowerBound(..), asVersionIntervals )-import Distribution.Verbosity (Verbosity)-import Distribution.Compiler  (CompilerFlavor(..))-import Distribution.PackageDescription.Configuration (parseCondition, freeVars)-import Distribution.Simple.Utils-         ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion-         , withFileContents, withUTF8FileContents-         , writeFileAtomic, writeUTF8File )----- -------------------------------------------------------------------------------- The PackageDescription type--pkgDescrFieldDescrs :: [FieldDescr PackageDescription]-pkgDescrFieldDescrs =-    [ simpleField "name"-           disp                   parse-           packageName            (\name pkg -> pkg{package=(package pkg){pkgName=name}})- , simpleField "version"-           disp                   parse-           packageVersion         (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}})- , simpleField "cabal-version"-           (either disp disp)     (liftM Left parse +++ liftM Right parse)-           specVersionRaw         (\v pkg -> pkg{specVersionRaw=v})- , simpleField "build-type"-           (maybe empty disp)     (fmap Just parse)-           buildType              (\t pkg -> pkg{buildType=t})- , simpleField "license"-           disp                   parseLicenseQ-           license                (\l pkg -> pkg{license=l})- , simpleField "license-file"-           showFilePath           parseFilePathQ-           licenseFile            (\l pkg -> pkg{licenseFile=l})- , simpleField "copyright"-           showFreeText           parseFreeText-           copyright              (\val pkg -> pkg{copyright=val})- , simpleField "maintainer"-           showFreeText           parseFreeText-           maintainer             (\val pkg -> pkg{maintainer=val})- , commaListField  "build-depends"-           disp                   parse-           buildDepends           (\xs    pkg -> pkg{buildDepends=xs})- , simpleField "stability"-           showFreeText           parseFreeText-           stability              (\val pkg -> pkg{stability=val})- , simpleField "homepage"-           showFreeText           parseFreeText-           homepage               (\val pkg -> pkg{homepage=val})- , simpleField "package-url"-           showFreeText           parseFreeText-           pkgUrl                 (\val pkg -> pkg{pkgUrl=val})- , simpleField "bug-reports"-           showFreeText           parseFreeText-           bugReports             (\val pkg -> pkg{bugReports=val})- , simpleField "synopsis"-           showFreeText           parseFreeText-           synopsis               (\val pkg -> pkg{synopsis=val})- , simpleField "description"-           showFreeText           parseFreeText-           description            (\val pkg -> pkg{description=val})- , simpleField "category"-           showFreeText           parseFreeText-           category               (\val pkg -> pkg{category=val})- , simpleField "author"-           showFreeText           parseFreeText-           author                 (\val pkg -> pkg{author=val})- , listField "tested-with"-           showTestedWith         parseTestedWithQ-           testedWith             (\val pkg -> pkg{testedWith=val})- , listField "data-files"-           showFilePath           parseFilePathQ-           dataFiles              (\val pkg -> pkg{dataFiles=val})- , simpleField "data-dir"-           showFilePath           parseFilePathQ-           dataDir                (\val pkg -> pkg{dataDir=val})- , listField "extra-source-files"-           showFilePath    parseFilePathQ-           extraSrcFiles          (\val pkg -> pkg{extraSrcFiles=val})- , listField "extra-tmp-files"-           showFilePath       parseFilePathQ-           extraTmpFiles          (\val pkg -> pkg{extraTmpFiles=val})- ]---- | Store any fields beginning with "x-" in the customFields field of---   a PackageDescription.  All other fields will generate a warning.-storeXFieldsPD :: UnrecFieldParser PackageDescription-storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD =-                                                        (customFieldsPD pkg) ++ [(f,val)]}-storeXFieldsPD _ _ = Nothing---- ------------------------------------------------------------------------------ The Library type--libFieldDescrs :: [FieldDescr Library]-libFieldDescrs =-  [ listField "exposed-modules" disp parseModuleNameQ-      exposedModules (\mods lib -> lib{exposedModules=mods})--  , boolField "exposed"-      libExposed     (\val lib -> lib{libExposed=val})-  ] ++ map biToLib binfoFieldDescrs-  where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi})--storeXFieldsLib :: UnrecFieldParser Library-storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) =-    Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}}-storeXFieldsLib _ _ = Nothing---- ------------------------------------------------------------------------------ The Executable type---executableFieldDescrs :: [FieldDescr Executable]-executableFieldDescrs =-  [ -- note ordering: configuration must come first, for-    -- showPackageDescription.-    simpleField "executable"-                           showToken          parseTokenQ-                           exeName            (\xs    exe -> exe{exeName=xs})-  , simpleField "main-is"-                           showFilePath       parseFilePathQ-                           modulePath         (\xs    exe -> exe{modulePath=xs})-  ]-  ++ map biToExe binfoFieldDescrs-  where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi})--storeXFieldsExe :: UnrecFieldParser Executable-storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) =-    Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}-storeXFieldsExe _ _ = Nothing---- ------------------------------------------------------------------------------ The TestSuite type---- | 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-     }--emptyTestStanza :: TestSuiteStanza-emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty--testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza]-testSuiteFieldDescrs =-    [ simpleField "type"-        (maybe empty disp)    (fmap Just parse)-        testStanzaTestType    (\x suite -> suite { testStanzaTestType = x })-    , simpleField "main-is"-        (maybe empty showFilePath)  (fmap Just parseFilePathQ)-        testStanzaMainIs      (\x suite -> suite { testStanzaMainIs = x })-    , simpleField "test-module"-        (maybe empty disp)    (fmap Just parseModuleNameQ)-        testStanzaTestModule  (\x suite -> suite { testStanzaTestModule = x })-    ]-    ++ map biToTest binfoFieldDescrs-  where-    biToTest = liftField testStanzaBuildInfo-                         (\bi suite -> suite { testStanzaBuildInfo = bi })--storeXFieldsTest :: UnrecFieldParser TestSuiteStanza-storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) =-    Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}-storeXFieldsTest _ _ = Nothing--validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite-validateTestSuite line stanza =-    case testStanzaTestType stanza of-      Nothing -> return $-        emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza }--      Just tt@(TestTypeUnknown _ _) ->-        return emptyTestSuite {-          testInterface = TestSuiteUnsupported tt,-          testBuildInfo = testStanzaBuildInfo stanza-        }--      Just tt | tt `notElem` knownTestTypes ->-        return emptyTestSuite {-          testInterface = TestSuiteUnsupported tt,-          testBuildInfo = testStanzaBuildInfo stanza-        }--      Just tt@(TestTypeExe ver) ->-        case testStanzaMainIs stanza of-          Nothing   -> syntaxError line (missingField "main-is" tt)-          Just file -> do-            when (isJust (testStanzaTestModule stanza)) $-              warning (extraField "test-module" tt)-            return emptyTestSuite {-              testInterface = TestSuiteExeV10 ver file,-              testBuildInfo = testStanzaBuildInfo stanza-            }--      Just tt@(TestTypeLib ver) ->-        case testStanzaTestModule stanza of-          Nothing      -> syntaxError line (missingField "test-module" tt)-          Just module_ -> do-            when (isJust (testStanzaMainIs stanza)) $-              warning (extraField "main-is" tt)-            return emptyTestSuite {-              testInterface = TestSuiteLibV09 ver module_,-              testBuildInfo = testStanzaBuildInfo stanza-            }--  where-    missingField name tt = "The '" ++ name ++ "' field is required for the "-                        ++ display tt ++ " test suite type."--    extraField   name tt = "The '" ++ name ++ "' field is not used for the '"-                        ++ display tt ++ "' test suite type."----- ------------------------------------------------------------------------------ The Benchmark type---- | 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-     }--emptyBenchmarkStanza :: BenchmarkStanza-emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty--benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza]-benchmarkFieldDescrs =-    [ simpleField "type"-        (maybe empty disp)    (fmap Just parse)-        benchmarkStanzaBenchmarkType-        (\x suite -> suite { benchmarkStanzaBenchmarkType = x })-    , simpleField "main-is"-        (maybe empty showFilePath)  (fmap Just parseFilePathQ)-        benchmarkStanzaMainIs-        (\x suite -> suite { benchmarkStanzaMainIs = x })-    ]-    ++ map biToBenchmark binfoFieldDescrs-  where-    biToBenchmark = liftField benchmarkStanzaBuildInfo-                    (\bi suite -> suite { benchmarkStanzaBuildInfo = bi })--storeXFieldsBenchmark :: UnrecFieldParser BenchmarkStanza-storeXFieldsBenchmark (f@('x':'-':_), val)-    t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) =-        Just $ t {benchmarkStanzaBuildInfo =-                       bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}-storeXFieldsBenchmark _ _ = Nothing--validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark-validateBenchmark line stanza =-    case benchmarkStanzaBenchmarkType stanza of-      Nothing -> return $-        emptyBenchmark { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza }--      Just tt@(BenchmarkTypeUnknown _ _) ->-        return emptyBenchmark {-          benchmarkInterface = BenchmarkUnsupported tt,-          benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza-        }--      Just tt | tt `notElem` knownBenchmarkTypes ->-        return emptyBenchmark {-          benchmarkInterface = BenchmarkUnsupported tt,-          benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza-        }--      Just tt@(BenchmarkTypeExe ver) ->-        case benchmarkStanzaMainIs stanza of-          Nothing   -> syntaxError line (missingField "main-is" tt)-          Just file -> do-            when (isJust (benchmarkStanzaBenchmarkModule stanza)) $-              warning (extraField "benchmark-module" tt)-            return emptyBenchmark {-              benchmarkInterface = BenchmarkExeV10 ver file,-              benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza-            }--  where-    missingField name tt = "The '" ++ name ++ "' field is required for the "-                        ++ display tt ++ " benchmark type."--    extraField   name tt = "The '" ++ name ++ "' field is not used for the '"-                        ++ display tt ++ "' benchmark type."---- ------------------------------------------------------------------------------ The BuildInfo type---binfoFieldDescrs :: [FieldDescr BuildInfo]-binfoFieldDescrs =- [ boolField "buildable"-           buildable          (\val binfo -> binfo{buildable=val})- , commaListField  "build-tools"-           disp               parseBuildTool-           buildTools         (\xs  binfo -> binfo{buildTools=xs})- , spaceListField "cpp-options"-           showToken          parseTokenQ'-           cppOptions          (\val binfo -> binfo{cppOptions=val})- , spaceListField "cc-options"-           showToken          parseTokenQ'-           ccOptions          (\val binfo -> binfo{ccOptions=val})- , spaceListField "ld-options"-           showToken          parseTokenQ'-           ldOptions          (\val binfo -> binfo{ldOptions=val})- , commaListField  "pkgconfig-depends"-           disp               parsePkgconfigDependency-           pkgconfigDepends   (\xs  binfo -> binfo{pkgconfigDepends=xs})- , listField "frameworks"-           showToken          parseTokenQ-           frameworks         (\val binfo -> binfo{frameworks=val})- , listField   "c-sources"-           showFilePath       parseFilePathQ-           cSources           (\paths binfo -> binfo{cSources=paths})-- , simpleField "default-language"-           (maybe empty disp) (option Nothing (fmap Just parseLanguageQ))-           defaultLanguage    (\lang  binfo -> binfo{defaultLanguage=lang})- , listField   "other-languages"-           disp               parseLanguageQ-           otherLanguages     (\langs binfo -> binfo{otherLanguages=langs})- , listField   "default-extensions"-           disp               parseExtensionQ-           defaultExtensions  (\exts  binfo -> binfo{defaultExtensions=exts})- , listField   "other-extensions"-           disp               parseExtensionQ-           otherExtensions    (\exts  binfo -> binfo{otherExtensions=exts})- , listField   "extensions"-           disp               parseExtensionQ-           oldExtensions      (\exts  binfo -> binfo{oldExtensions=exts})-- , listField   "extra-libraries"-           showToken          parseTokenQ-           extraLibs          (\xs    binfo -> binfo{extraLibs=xs})- , listField   "extra-lib-dirs"-           showFilePath       parseFilePathQ-           extraLibDirs       (\xs    binfo -> binfo{extraLibDirs=xs})- , listField   "includes"-           showFilePath       parseFilePathQ-           includes           (\paths binfo -> binfo{includes=paths})- , listField   "install-includes"-           showFilePath       parseFilePathQ-           installIncludes    (\paths binfo -> binfo{installIncludes=paths})- , listField   "include-dirs"-           showFilePath       parseFilePathQ-           includeDirs        (\paths binfo -> binfo{includeDirs=paths})- , listField   "hs-source-dirs"-           showFilePath       parseFilePathQ-           hsSourceDirs       (\paths binfo -> binfo{hsSourceDirs=paths})- , listField   "other-modules"-           disp               parseModuleNameQ-           otherModules       (\val binfo -> binfo{otherModules=val})- , listField   "ghc-prof-options"-           text               parseTokenQ-           ghcProfOptions        (\val binfo -> binfo{ghcProfOptions=val})- , listField   "ghc-shared-options"-           text               parseTokenQ-           ghcSharedOptions      (\val binfo -> binfo{ghcSharedOptions=val})- , optsField   "ghc-options"  GHC-           options            (\path  binfo -> binfo{options=path})- , optsField   "hugs-options" Hugs-           options            (\path  binfo -> binfo{options=path})- , optsField   "nhc98-options"  NHC-           options            (\path  binfo -> binfo{options=path})- , optsField   "jhc-options"  JHC-           options            (\path  binfo -> binfo{options=path})- ]--storeXFieldsBI :: UnrecFieldParser BuildInfo-storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) }-storeXFieldsBI _ _ = Nothing----------------------------------------------------------------------------------flagFieldDescrs :: [FieldDescr Flag]-flagFieldDescrs =-    [ simpleField "description"-        showFreeText     parseFreeText-        flagDescription  (\val fl -> fl{ flagDescription = val })-    , boolField "default"-        flagDefault      (\val fl -> fl{ flagDefault = val })-    , boolField "manual"-        flagManual       (\val fl -> fl{ flagManual = val })-    ]----------------------------------------------------------------------------------sourceRepoFieldDescrs :: [FieldDescr SourceRepo]-sourceRepoFieldDescrs =-    [ simpleField "type"-        (maybe empty disp)         (fmap Just parse)-        repoType                   (\val repo -> repo { repoType = val })-    , simpleField "location"-        (maybe empty showFreeText) (fmap Just parseFreeText)-        repoLocation               (\val repo -> repo { repoLocation = val })-    , simpleField "module"-        (maybe empty showToken)    (fmap Just parseTokenQ)-        repoModule                 (\val repo -> repo { repoModule = val })-    , simpleField "branch"-        (maybe empty showToken)    (fmap Just parseTokenQ)-        repoBranch                 (\val repo -> repo { repoBranch = val })-    , simpleField "tag"-        (maybe empty showToken)    (fmap Just parseTokenQ)-        repoTag                    (\val repo -> repo { repoTag = val })-    , simpleField "subdir"-        (maybe empty showFilePath) (fmap Just parseFilePathQ)-        repoSubdir                 (\val repo -> repo { repoSubdir = val })-    ]---- ------------------------------------------------------------------ Parsing---- | Given a parser and a filename, return the parse of the file,--- after checking if the file exists.-readAndParseFile :: (FilePath -> (String -> IO a) -> IO a)-                 -> (String -> ParseResult a)-                 -> Verbosity-                 -> FilePath -> IO a-readAndParseFile withFileContents' parser verbosity fpath = do-  exists <- doesFileExist fpath-  when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.")-  withFileContents' fpath $ \str -> case parser str of-    ParseFailed e -> do-        let (line, message) = locatedErrorMsg e-        dieWithLocation fpath line message-    ParseOk warnings x -> do-        mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings-        return x--readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo-readHookedBuildInfo =-    readAndParseFile withFileContents parseHookedBuildInfo---- |Parse the given package file.-readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription-readPackageDescription =-    readAndParseFile withUTF8FileContents parsePackageDescription--stanzas :: [Field] -> [[Field]]-stanzas [] = []-stanzas (f:fields) = (f:this) : stanzas rest-  where-    (this, rest) = break isStanzaHeader fields--isStanzaHeader :: Field -> Bool-isStanzaHeader (F _ f _) = f == "executable"-isStanzaHeader _ = False-----------------------------------------------------------------------------------mapSimpleFields :: (Field -> ParseResult Field) -> [Field]-                -> ParseResult [Field]-mapSimpleFields f fs = mapM walk fs-  where-    walk fld@(F _ _ _) = f fld-    walk (IfBlock l c fs1 fs2) = do-      fs1' <- mapM walk fs1-      fs2' <- mapM walk fs2-      return (IfBlock l c fs1' fs2')-    walk (Section ln n l fs1) = do-      fs1' <-  mapM walk fs1-      return (Section ln n l fs1')---- prop_isMapM fs = mapSimpleFields return fs == return fs----- names of fields that represents dependencies, thus consrca-constraintFieldNames :: [String]-constraintFieldNames = ["build-depends"]---- Possible refactoring would be to have modifiers be explicit about what--- they add and define an accessor that specifies what the dependencies--- are.  This way we would completely reuse the parsing knowledge from the--- field descriptor.-parseConstraint :: Field -> ParseResult [Dependency]-parseConstraint (F l n v)-    | n == "build-depends" = runP l n (parseCommaList parse) v-parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")"--{--headerFieldNames :: [String]-headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames))-                 . map fieldName $ pkgDescrFieldDescrs--}--libFieldNames :: [String]-libFieldNames = map fieldName libFieldDescrs-                ++ buildInfoNames ++ constraintFieldNames---- exeFieldNames :: [String]--- exeFieldNames = map fieldName executableFieldDescrs---                 ++ buildInfoNames--buildInfoNames :: [String]-buildInfoNames = map fieldName binfoFieldDescrs-                ++ map fst deprecatedFieldsBuildInfo---- A minimal implementation of the StateT monad transformer to avoid depending--- on the 'mtl' package.-newtype StT s m a = StT { runStT :: s -> m (a,s) }--instance Monad m => Monad (StT s m) where-    return a = StT (\s -> return (a,s))-    StT f >>= g = StT $ \s -> do-                        (a,s') <- f s-                        runStT (g a) s'--get :: Monad m => StT s m s-get = StT $ \s -> return (s, s)--modify :: Monad m => (s -> s) -> StT s m ()-modify f = StT $ \s -> return ((),f s)--lift :: Monad m => m a -> StT s m a-lift m = StT $ \s -> m >>= \a -> return (a,s)--evalStT :: Monad m => StT s m a -> s -> m a-evalStT st s = runStT st s >>= return . fst---- Our monad for parsing a list/tree of fields.------ The state represents the remaining fields to be processed.-type PM a = StT [Field] ParseResult a------ return look-ahead field or nothing if we're at the end of the file-peekField :: PM (Maybe Field)-peekField = get >>= return . listToMaybe---- Unconditionally discard the first field in our state.  Will error when it--- reaches end of file.  (Yes, that's evil.)-skipField :: PM ()-skipField = modify tail----FIXME: this should take a ByteString, not a String. We have to be able to--- decode UTF8 and handle the BOM.---- | 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.-parsePackageDescription :: String -> ParseResult GenericPackageDescription-parsePackageDescription file = do--    -- This function is quite complex because it needs to be able to parse-    -- both pre-Cabal-1.2 and post-Cabal-1.2 files.  Additionally, it contains-    -- a lot of parser-related noise since we do not want to depend on Parsec.-    ---    -- If we detect an pre-1.2 file we implicitly convert it to post-1.2-    -- style.  See 'sectionizeFields' below for details about the conversion.--    fields0 <- readFields file `catchParseError` \err ->-                 let tabs = findIndentTabs file in-                 case err of-                   -- In case of a TabsError report them all at once.-                   TabsError tabLineNo -> reportTabsError-                   -- but only report the ones including and following-                   -- the one that caused the actual error-                                            [ t | t@(lineNo',_) <- tabs-                                                , lineNo' >= tabLineNo ]-                   _ -> parseFail err--    let cabalVersionNeeded =-          head $ [ minVersionBound versionRange-                 | Just versionRange <- [ simpleParse v-                                        | F _ "cabal-version" v <- fields0 ] ]-              ++ [Version [0] []]-        minVersionBound versionRange =-          case asVersionIntervals versionRange of-            []                            -> Version [0] []-            ((LowerBound version _, _):_) -> version--    handleFutureVersionParseFailure cabalVersionNeeded $ do--      let sf = sectionizeFields fields0  -- ensure 1.2 format--        -- figure out and warn about deprecated stuff (warnings are collected-        -- inside our parsing monad)-      fields <- mapSimpleFields deprecField sf--        -- Our parsing monad takes the not-yet-parsed fields as its state.-        -- After each successful parse we remove the field from the state-        -- ('skipField') and move on to the next one.-        ---        -- Things are complicated a bit, because fields take a tree-like-        -- structure -- they can be sections or "if"/"else" conditionals.--      flip evalStT fields $ do--          -- The header consists of all simple fields up to the first section-          -- (flag, library, executable).-        header_fields <- getHeader []--          -- Parses just the header fields and stores them in a-          -- 'PackageDescription'.  Note that our final result is a-          -- 'GenericPackageDescription'; for pragmatic reasons we just store-          -- the partially filled-out 'PackageDescription' inside the-          -- 'GenericPackageDescription'.-        pkg <- lift $ parseFields pkgDescrFieldDescrs-                                  storeXFieldsPD-                                  emptyPackageDescription-                                  header_fields--          -- 'getBody' assumes that the remaining fields only consist of-          -- flags, lib and exe sections.-        (repos, flags, mlib, exes, tests, bms) <- getBody-        warnIfRest  -- warn if getBody did not parse up to the last field.-          -- warn about using old/new syntax with wrong cabal-version:-        maybeWarnCabalVersion (not $ oldSyntax fields0) pkg-        checkForUndefinedFlags flags mlib exes tests-        return $ GenericPackageDescription-                   pkg { sourceRepos = repos }-                   flags mlib exes tests bms--  where-    oldSyntax flds = all isSimpleField flds-    reportTabsError tabs =-        syntaxError (fst (head tabs)) $-          "Do not use tabs for indentation (use spaces instead)\n"-          ++ "  Tabs were used at (line,column): " ++ show tabs--    maybeWarnCabalVersion newsyntax pkg-      | newsyntax && specVersion pkg < Version [1,2] []-      = lift $ warning $-             "A package using section syntax must specify at least\n"-          ++ "'cabal-version: >= 1.2'."--    maybeWarnCabalVersion newsyntax pkg-      | not newsyntax && specVersion pkg >= Version [1,2] []-      = lift $ warning $-             "A package using 'cabal-version: "-          ++ displaySpecVersion (specVersionRaw pkg)-          ++ "' must use section syntax. See the Cabal user guide for details."-      where-        displaySpecVersion (Left version)       = display version-        displaySpecVersion (Right versionRange) =-          case asVersionIntervals versionRange of-            [] {- impossible -}           -> display versionRange-            ((LowerBound version _, _):_) -> display (orLaterVersion version)--    maybeWarnCabalVersion _ _ = return ()---    handleFutureVersionParseFailure cabalVersionNeeded parseBody =-      (unless versionOk (warning message) >> parseBody)-        `catchParseError` \parseError -> case parseError of-        TabsError _   -> parseFail parseError-        _ | versionOk -> parseFail parseError-          | otherwise -> fail message-      where versionOk = cabalVersionNeeded <= cabalVersion-            message   = "This package requires at least Cabal version "-                     ++ display cabalVersionNeeded--    -- "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 implementatition just gathers all library-specific fields-    -- in a library section and wraps all executable stanzas in an executable-    -- section.-    sectionizeFields :: [Field] -> [Field]-    sectionizeFields fs-      | oldSyntax fs =-          let-            -- "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") . fName) fs-            (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0--            (deps, libfs) = partition ((== "build-depends") . fName)-                                       libfs0--            exes = unfoldr toExe exes0-            toExe [] = Nothing-            toExe (F l e n : r)-              | e == "executable" =-                  let (efs, r') = break ((=="executable") . fName) r-                  in Just (Section l "executable" n (deps ++ efs), r')-            toExe _ = bug "unexpeced input to 'toExe'"-          in-            hdr ++-           (if null libfs then []-            else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)])-            ++ exes-      | otherwise = fs--    isSimpleField (F _ _ _) = True-    isSimpleField _ = False--    -- warn if there's something at the end of the file-    warnIfRest :: PM ()-    warnIfRest = do-      s <- get-      case s of-        [] -> return ()-        _ -> lift $ warning "Ignoring trailing declarations."  -- add line no.--    -- all simple fields at the beginning of the file are (considered) header-    -- fields-    getHeader :: [Field] -> PM [Field]-    getHeader acc = peekField >>= \mf -> case mf of-        Just f@(F _ _ _) -> skipField >> getHeader (f:acc)-        _ -> return (reverse acc)--    ---    -- body ::= { repo | flag | library | executable | test }+   -- at most one lib-    ---    -- The body consists of an optional sequence of declarations of flags and-    -- an arbitrary number of executables and at most one library.-    getBody :: PM ([SourceRepo], [Flag]-                  ,Maybe (CondTree ConfVar [Dependency] Library)-                  ,[(String, CondTree ConfVar [Dependency] Executable)]-                  ,[(String, CondTree ConfVar [Dependency] TestSuite)]-                  ,[(String, CondTree ConfVar [Dependency] Benchmark)])-    getBody = peekField >>= \mf -> case mf of-      Just (Section line_no sec_type sec_label sec_fields)-        | sec_type == "executable" -> do-            when (null sec_label) $ lift $ syntaxError line_no-              "'executable' needs one argument (the executable's name)"-            exename <- lift $ runP line_no "executable" parseTokenQ sec_label-            flds <- collectFields parseExeFields sec_fields-            skipField-            (repos, flags, lib, exes, tests, bms) <- getBody-            return (repos, flags, lib, (exename, flds): exes, tests, bms)--        | sec_type == "test-suite" -> do-            when (null sec_label) $ lift $ syntaxError line_no-                "'test-suite' needs one argument (the test suite's name)"-            testname <- lift $ runP line_no "test" parseTokenQ sec_label-            flds <- collectFields (parseTestFields line_no) sec_fields--            -- Check that a valid test suite type has been chosen. A type-            -- field may be given inside a conditional block, so we must-            -- check for that before complaining that a type field has not-            -- been given. The test suite must always have a valid type, so-            -- we need to check both the 'then' and 'else' blocks, though-            -- the blocks need not have the same type.-            let checkTestType ts ct =-                    let ts' = mappend ts $ condTreeData ct-                        -- If a conditional has only a 'then' block and no-                        -- 'else' block, then it cannot have a valid type-                        -- in every branch, unless the type is specified at-                        -- a higher level in the tree.-                        checkComponent (_, _, Nothing) = False-                        -- If a conditional has a 'then' block and an 'else'-                        -- block, both must specify a test type, unless the-                        -- type is specified higher in the tree.-                        checkComponent (_, t, Just e) =-                            checkTestType ts' t && checkTestType ts' e-                        -- Does the current node specify a test type?-                        hasTestType = testInterface ts'-                            /= testInterface emptyTestSuite-                        components = condTreeComponents ct-                    -- If the current level of the tree specifies a type,-                    -- then we are done. If not, then one of the conditional-                    -- branches below the current node must specify a type.-                    -- Each node may have multiple immediate children; we-                    -- only one need one to specify a type because the-                    -- configure step uses 'mappend' to join together the-                    -- results of flag resolution.-                    in hasTestType || (any checkComponent components)-            if checkTestType emptyTestSuite flds-                then do-                    skipField-                    (repos, flags, lib, exes, tests, bms) <- getBody-                    return (repos, flags, lib, exes, (testname, flds) : tests, bms)-                else lift $ syntaxError line_no $-                         "Test suite \"" ++ testname-                      ++ "\" is missing required field \"type\" or the field "-                      ++ "is not present in all conditional branches. The "-                      ++ "available test types are: "-                      ++ intercalate ", " (map display knownTestTypes)--        | sec_type == "benchmark" -> do-            when (null sec_label) $ lift $ syntaxError line_no-                "'benchmark' needs one argument (the benchmark's name)"-            benchname <- lift $ runP line_no "benchmark" parseTokenQ sec_label-            flds <- collectFields (parseBenchmarkFields line_no) sec_fields--            -- Check that a valid benchmark type has been chosen. A type-            -- field may be given inside a conditional block, so we must-            -- check for that before complaining that a type field has not-            -- been given. The benchmark must always have a valid type, so-            -- we need to check both the 'then' and 'else' blocks, though-            -- the blocks need not have the same type.-            let checkBenchmarkType ts ct =-                    let ts' = mappend ts $ condTreeData ct-                        -- If a conditional has only a 'then' block and no-                        -- 'else' block, then it cannot have a valid type-                        -- in every branch, unless the type is specified at-                        -- a higher level in the tree.-                        checkComponent (_, _, Nothing) = False-                        -- If a conditional has a 'then' block and an 'else'-                        -- block, both must specify a benchmark type, unless the-                        -- type is specified higher in the tree.-                        checkComponent (_, t, Just e) =-                            checkBenchmarkType ts' t && checkBenchmarkType ts' e-                        -- Does the current node specify a benchmark type?-                        hasBenchmarkType = benchmarkInterface ts'-                            /= benchmarkInterface emptyBenchmark-                        components = condTreeComponents ct-                    -- If the current level of the tree specifies a type,-                    -- then we are done. If not, then one of the conditional-                    -- branches below the current node must specify a type.-                    -- Each node may have multiple immediate children; we-                    -- only one need one to specify a type because the-                    -- configure step uses 'mappend' to join together the-                    -- results of flag resolution.-                    in hasBenchmarkType || (any checkComponent components)-            if checkBenchmarkType emptyBenchmark flds-                then do-                    skipField-                    (repos, flags, lib, exes, tests, bms) <- getBody-                    return (repos, flags, lib, exes, tests, (benchname, flds) : bms)-                else lift $ syntaxError line_no $-                         "Benchmark \"" ++ benchname-                      ++ "\" is missing required field \"type\" or the field "-                      ++ "is not present in all conditional branches. The "-                      ++ "available benchmark types are: "-                      ++ intercalate ", " (map display knownBenchmarkTypes)--        | sec_type == "library" -> do-            when (not (null sec_label)) $ lift $-              syntaxError line_no "'library' expects no argument"-            flds <- collectFields parseLibFields sec_fields-            skipField-            (repos, flags, lib, exes, tests, bms) <- getBody-            when (isJust lib) $ lift $ syntaxError line_no-              "There can only be one library section in a package description."-            return (repos, flags, Just flds, exes, tests, bms)--        | sec_type == "flag" -> do-            when (null sec_label) $ lift $-              syntaxError line_no "'flag' needs one argument (the flag's name)"-            flag <- lift $ parseFields-                    flagFieldDescrs-                    warnUnrec-                    (MkFlag (FlagName (lowercase sec_label)) "" True False)-                    sec_fields-            skipField-            (repos, flags, lib, exes, tests, bms) <- getBody-            return (repos, flag:flags, lib, exes, tests, bms)--        | sec_type == "source-repository" -> do-            when (null sec_label) $ lift $ syntaxError line_no $-                 "'source-repository' needs one argument, "-              ++ "the repo kind which is usually 'head' or 'this'"-            kind <- case simpleParse sec_label of-              Just kind -> return kind-              Nothing   -> lift $ syntaxError line_no $-                             "could not parse repo kind: " ++ sec_label-            repo <- lift $ parseFields-                    sourceRepoFieldDescrs-                    warnUnrec-                    (SourceRepo {-                      repoKind     = kind,-                      repoType     = Nothing,-                      repoLocation = Nothing,-                      repoModule   = Nothing,-                      repoBranch   = Nothing,-                      repoTag      = Nothing,-                      repoSubdir   = Nothing-                    })-                    sec_fields-            skipField-            (repos, flags, lib, exes, tests, bms) <- getBody-            return (repo:repos, flags, lib, exes, tests, bms)--        | otherwise -> do-            lift $ warning $ "Ignoring unknown section type: " ++ sec_type-            skipField-            getBody-      Just f -> do-            _ <- lift $ syntaxError (lineNo f) $-              "Construct not supported at this position: " ++ show f-            skipField-            getBody-      Nothing -> return ([], [], Nothing, [], [], [])--    -- Extracts all fields in a block and returns a 'CondTree'.-    ---    -- We have to recurse down into conditionals and we treat fields that-    -- describe dependencies specially.-    collectFields :: ([Field] -> PM a) -> [Field]-                  -> PM (CondTree ConfVar [Dependency] a)-    collectFields parser allflds = do--        let simplFlds = [ F l n v | F l n v <- allflds ]-            condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ]--        let (depFlds, dataFlds) = partition isConstraint simplFlds--        a <- parser dataFlds-        deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds--        ifs <- mapM processIfs condFlds--        return (CondNode a deps ifs)-      where-        isConstraint (F _ n _) = n `elem` constraintFieldNames-        isConstraint _ = False--        processIfs (IfBlock l c t e) = do-            cnd <- lift $ runP l "if" parseCondition c-            t' <- collectFields parser t-            e' <- case e of-                   [] -> return Nothing-                   es -> do fs <- collectFields parser es-                            return (Just fs)-            return (cnd, t', e')-        processIfs _ = bug "processIfs called with wrong field type"--    parseLibFields :: [Field] -> PM Library-    parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary--    -- Note: we don't parse the "executable" field here, hence the tail hack.-    parseExeFields :: [Field] -> PM Executable-    parseExeFields = lift . parseFields (tail executableFieldDescrs) storeXFieldsExe emptyExecutable--    parseTestFields :: LineNo -> [Field] -> PM TestSuite-    parseTestFields line fields = do-        x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest-                                emptyTestStanza fields-        lift $ validateTestSuite line x--    parseBenchmarkFields :: LineNo -> [Field] -> PM Benchmark-    parseBenchmarkFields line fields = do-        x <- lift $ parseFields benchmarkFieldDescrs storeXFieldsBenchmark-                                emptyBenchmarkStanza fields-        lift $ validateBenchmark line x--    checkForUndefinedFlags ::-        [Flag] ->-        Maybe (CondTree ConfVar [Dependency] Library) ->-        [(String, CondTree ConfVar [Dependency] Executable)] ->-        [(String, CondTree ConfVar [Dependency] TestSuite)] ->-        PM ()-    checkForUndefinedFlags flags mlib exes tests = do-        let definedFlags = map flagName flags-        maybe (return ()) (checkCondTreeFlags definedFlags) mlib-        mapM_ (checkCondTreeFlags definedFlags . snd) exes-        mapM_ (checkCondTreeFlags definedFlags . snd) tests--    checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()-    checkCondTreeFlags definedFlags ct = do-        let fv = nub $ freeVars ct-        when (not . all (`elem` definedFlags) $ fv) $-            fail $ "These flags are used without having been defined: "-                ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ]----- | Parse a list of fields, given a list of field descriptions,---   a structure to accumulate the parsed fields, and a function---   that can decide what to do with fields which don't match any---   of the field descriptions.-parseFields :: [FieldDescr a]      -- ^ descriptions of fields we know how to-                                   --   parse-            -> UnrecFieldParser a  -- ^ possibly do something with-                                   --   unrecognized fields-            -> a                   -- ^ accumulator-            -> [Field]             -- ^ fields to be parsed-            -> ParseResult a-parseFields descrs unrec ini fields =-    do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields-       when (not (null unknowns)) $ do-         warning $ render $-           text "Unknown fields:" <+>-                commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")")-                              (reverse unknowns))-           $+$-           text "Fields allowed in this section:" $$-             nest 4 (commaSep $ map fieldName descrs)-       return a-  where-    commaSep = fsep . punctuate comma . map text--parseField :: [FieldDescr a]     -- ^ list of parseable fields-           -> UnrecFieldParser a -- ^ possibly do something with-                                 --   unrecognized fields-           -> (a,[(Int,String)]) -- ^ accumulated result and warnings-           -> Field              -- ^ the field to be parsed-           -> ParseResult (a, [(Int,String)])-parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val)-  | name == f = parser line val a >>= \a' -> return (a',us)-  | otherwise = parseField fields unrec (a,us) (F line f val)-parseField [] unrec (a,us) (F l f val) = return $-  case unrec (f,val) a of        -- no fields matched, see if the 'unrec'-    Just a' -> (a',us)           -- function wants to do anything with it-    Nothing -> (a, ((l,f):us))-parseField _ _ _ _ = bug "'parseField' called on a non-field"--deprecatedFields :: [(String,String)]-deprecatedFields =-    deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo--deprecatedFieldsPkgDescr :: [(String,String)]-deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ]--deprecatedFieldsBuildInfo :: [(String,String)]-deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ]---- Handle deprecated fields-deprecField :: Field -> ParseResult Field-deprecField (F line fld val) = do-  fld' <- case lookup fld deprecatedFields of-            Nothing -> return fld-            Just newName -> do-              warning $ "The field \"" ++ fld-                      ++ "\" is deprecated, please use \"" ++ newName ++ "\""-              return newName-  return (F line fld' val)-deprecField _ = bug "'deprecField' called on a non-field"---parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo-parseHookedBuildInfo inp = do-  fields <- readFields inp-  let ss@(mLibFields:exes) = stanzas fields-  mLib <- parseLib mLibFields-  biExes <- mapM parseExe (maybe ss (const exes) mLib)-  return (mLib, biExes)-  where-    parseLib :: [Field] -> ParseResult (Maybe BuildInfo)-    parseLib (bi@((F _ inFieldName _):_))-        | lowercase inFieldName /= "executable" = liftM Just (parseBI bi)-    parseLib _ = return Nothing--    parseExe :: [Field] -> ParseResult (String, BuildInfo)-    parseExe ((F line inFieldName mName):bi)-        | lowercase inFieldName == "executable"-            = do bis <- parseBI bi-                 return (mName, bis)-        | otherwise = syntaxError line "expecting 'executable' at top of stanza"-    parseExe (_:_) = bug "`parseExe' called on a non-field"-    parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza"--    parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st---- ------------------------------------------------------------------------------ Pretty printing--writePackageDescription :: FilePath -> PackageDescription -> IO ()-writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)----TODO: make this use section syntax--- add equivalent for GenericPackageDescription-showPackageDescription :: PackageDescription -> String-showPackageDescription pkg = render $-     ppPackage pkg-  $$ ppCustomFields (customFieldsPD pkg)-  $$ (case library pkg of-        Nothing  -> empty-        Just lib -> ppLibrary lib)-  $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ]-  where-    ppPackage    = ppFields pkgDescrFieldDescrs-    ppLibrary    = ppFields libFieldDescrs-    ppExecutable = ppFields executableFieldDescrs--ppCustomFields :: [(String,String)] -> Doc-ppCustomFields flds = vcat (map ppCustomField flds)--ppCustomField :: (String,String) -> Doc-ppCustomField (name,val) = text name <> colon <+> showFreeText val--writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()-writeHookedBuildInfo fpath = writeFileAtomic fpath . showHookedBuildInfo--showHookedBuildInfo :: HookedBuildInfo -> String-showHookedBuildInfo (mb_lib_bi, ex_bis) = render $-     (case mb_lib_bi of-        Nothing -> empty-        Just bi -> ppBuildInfo bi)-  $$ vcat [    space-            $$ text "executable:" <+> text name-            $$ ppBuildInfo bi-          | (name, bi) <- ex_bis ]-  where-    ppBuildInfo bi = ppFields binfoFieldDescrs bi-                  $$ ppCustomFields (customFieldsBI bi)---- replace all tabs used as indentation with whitespace, also return where--- tabs were found-findIndentTabs :: String -> [(Int,Int)]-findIndentTabs = concatMap checkLine-               . zip [1..]-               . lines-    where-      checkLine (lineno, l) =-          let (indent, _content) = span isSpace l-              tabCols = map fst . filter ((== '\t') . snd) . zip [0..]-              addLineNo = map (\col -> (lineno,col))-          in addLineNo (tabCols indent)----test_findIndentTabs = findIndentTabs $ unlines $---    [ "foo", "  bar", " \t baz", "\t  biz\t", "\t\t \t mib" ]--bug :: String -> a-bug msg = error $ msg ++ ". Consider this a bug."
− Distribution/PackageDescription/PrettyPrint.hs 
@@ -1,238 +0,0 @@------------------------------------------------------------------------------------ Module      :  Distribution.PackageDescription.PrettyPrint--- Copyright   :  Jürgen Nicklisch-Franken 2010--- License     :  AllRightsReserved------ Maintainer  : cabal-devel@haskell.org--- Stability   : provisional--- Portability : portable------ | Pretty printing for cabal files----------------------------------------------------------------------------------{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.PackageDescription.PrettyPrint (-    writeGenericPackageDescription,-    showGenericPackageDescription,-) where--import Distribution.PackageDescription-       ( TestSuite(..), TestSuiteInterface(..), testType-       , SourceRepo(..),-        customFieldsBI, CondTree(..), Condition(..),-        FlagName(..), ConfVar(..), Executable(..), Library(..),-        Flag(..), PackageDescription(..),-        GenericPackageDescription(..))-import Text.PrettyPrint-       (hsep, comma, punctuate, fsep, parens, char, nest, empty,-        isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)-import Distribution.Simple.Utils (writeUTF8File)-import Distribution.ParseUtils (showFreeText, FieldDescr(..))-import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,-       sourceRepoFieldDescrs)-import Distribution.Package (Dependency(..))-import Distribution.Text (Text(..))-import Data.Maybe (isJust, fromJust, isNothing)--indentWith :: Int-indentWith = 4---- | Recompile with false for regression testing-simplifiedPrinting :: Bool-simplifiedPrinting = False---- | 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            = render . ppGenericPackageDescription--ppGenericPackageDescription :: GenericPackageDescription -> Doc-ppGenericPackageDescription gpd          =-        ppPackageDescription (packageDescription gpd)-        $+$ ppGenPackageFlags (genPackageFlags gpd)-        $+$ ppLibrary (condLibrary gpd)-        $+$ ppExecutables (condExecutables gpd)-        $+$ ppTestSuites (condTestSuites gpd)--ppPackageDescription :: PackageDescription -> Doc-ppPackageDescription pd                  =      ppFields pkgDescrFieldDescrs pd-                                                $+$ ppCustomFields (customFieldsPD pd)-                                                $+$ ppSourceRepos (sourceRepos pd)--ppSourceRepos :: [SourceRepo] -> Doc-ppSourceRepos []                         = empty-ppSourceRepos (hd:tl)                    = ppSourceRepo hd $+$ ppSourceRepos tl--ppSourceRepo :: SourceRepo -> Doc-ppSourceRepo repo                        =-    emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$-        (nest indentWith (ppFields sourceRepoFieldDescrs' repo))-  where-    sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"]--ppFields :: [FieldDescr a] -> a -> Doc-ppFields fields x                        =-    vcat [ ppField name (getter x)-                         | FieldDescr name getter _ <- fields]--ppField :: String -> Doc -> Doc-ppField name fielddoc | isEmpty fielddoc = empty-                      | otherwise        = text name <> colon <+> fielddoc--ppDiffFields :: [FieldDescr a] -> a -> a -> Doc-ppDiffFields fields x y                  =-    vcat [ ppField name (getter x)-                         | FieldDescr name getter _ <- fields,-                            render (getter x) /= render (getter y)]--ppCustomFields :: [(String,String)] -> Doc-ppCustomFields flds                      = vcat [ppCustomField f | f <- flds]--ppCustomField :: (String,String) -> Doc-ppCustomField (name,val)                 = text name <> colon <+> showFreeText val--ppGenPackageFlags :: [Flag] -> Doc-ppGenPackageFlags flds                   = vcat [ppFlag f | f <- flds]--ppFlag :: Flag -> Doc-ppFlag (MkFlag name desc dflt manual)    =-    emptyLine $ text "flag" <+> ppFlagName name $+$-            (nest indentWith ((if null desc-                                then empty-                                else  text "Description: " <+> showFreeText desc) $+$-                     (if dflt then empty else text "Default: False") $+$-                     (if manual then text "Manual: True" else empty)))--ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc-ppLibrary Nothing                        = empty-ppLibrary (Just condTree)                =-    emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib)-  where-    ppLib lib Nothing     = ppFields libFieldDescrs lib-                            $$  ppCustomFields (customFieldsBI (libBuildInfo lib))-    ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib-                            $$  ppCustomFields (customFieldsBI (libBuildInfo lib))--ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc-ppExecutables exes                       =-    vcat [emptyLine $ text ("executable " ++ n)-              $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes]-  where-    ppExe (Executable _ modulePath' buildInfo') Nothing =-        (if modulePath' == "" then empty else text "main-is:" <+> text modulePath')-            $+$ ppFields binfoFieldDescrs buildInfo'-            $+$  ppCustomFields (customFieldsBI buildInfo')-    ppExe (Executable _ modulePath' buildInfo')-            (Just (Executable _ modulePath2 buildInfo2)) =-            (if modulePath' == "" || modulePath' == modulePath2-                then empty else text "main-is:" <+> text modulePath')-            $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2-            $+$ ppCustomFields (customFieldsBI buildInfo')--ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc-ppTestSuites suites =-    emptyLine $ vcat [     text ("test-suite " ++ n)-                       $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite)-                     | (n,condTree) <- suites]-  where-    ppTestSuite testsuite Nothing =-                text "type:" <+> disp (testType testsuite)-            $+$ maybe empty (\f -> text "main-is:"     <+> text f)-                            (testSuiteMainIs testsuite)-            $+$ maybe empty (\m -> text "test-module:" <+> disp m)-                            (testSuiteModule testsuite)-            $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)-            $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))--    ppTestSuite (TestSuite _ _ buildInfo' _)-                    (Just (TestSuite _ _ buildInfo2 _)) =-            ppDiffFields binfoFieldDescrs buildInfo' buildInfo2-            $+$ ppCustomFields (customFieldsBI buildInfo')--    testSuiteMainIs test = case testInterface test of-      TestSuiteExeV10 _ f -> Just f-      _                   -> Nothing--    testSuiteModule test = case testInterface test of-      TestSuiteLibV09 _ m -> Just m-      _                   -> Nothing--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 (disp os)-ppConfVar (Arch arch)                    = text "arch" <> parens (disp arch)-ppConfVar (Flag name)                    = text "flag" <> parens (ppFlagName name)-ppConfVar (Impl c v)                     = text "impl" <> parens (disp c <+> disp v)--ppFlagName :: FlagName -> Doc-ppFlagName (FlagName name)               = text name--ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) ->  Doc-ppCondTree ct@(CondNode it deps ifs) mbIt ppIt =-    let res = ppDeps deps-                $+$ (vcat $ map ppIf ifs)-                $+$ ppIt it mbIt-    in if isJust mbIt && isEmpty res-        then ppCondTree ct Nothing ppIt-        else res-  where-    ppIf (c,thenTree,mElseTree)          =-        ((emptyLine $ text "if" <+> ppCondition c) $$-          nest indentWith (ppCondTree thenTree-                    (if simplifiedPrinting then (Just it) else Nothing) ppIt))-        $+$ (if isNothing mElseTree-                then empty-                else text "else"-                    $$ nest indentWith (ppCondTree (fromJust mElseTree)-                        (if simplifiedPrinting then (Just it) else Nothing) ppIt))--ppDeps :: [Dependency] -> Doc-ppDeps []                                = empty-ppDeps deps                              =-    text "build-depends:" <+> fsep (punctuate comma (map disp deps))--emptyLine :: Doc -> Doc-emptyLine d                              = text " " $+$ d---
− Distribution/ParseUtils.hs 
@@ -1,715 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.ParseUtils--- Copyright   :  (c) The University of Glasgow 2004------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'.------ The @.cabal@ file format is not trivial, especially with the introduction--- of configurations and the section syntax that goes with that. This module--- has a bunch of parsing functions that is used by the @.cabal@ parser and a--- couple others. It has the parsing framework code and also little parsers for--- many of the formats we get in various @.cabal@ file fields, like module--- names, comma separated lists etc.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of the University nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}---- This module is meant to be local-only to Distribution...---- #hide-module Distribution.ParseUtils (-        LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,-        runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning,-        Field(..), fName, lineNo,-        FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat,-        showFields, showSingleNamedField, parseFields, parseFieldsFlat,-        parseFilePathQ, parseTokenQ, parseTokenQ',-        parseModuleNameQ, parseBuildTool, parsePkgconfigDependency,-        parseOptVersion, parsePackageNameQ, parseVersionRangeQ,-        parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ,-        parseSepList, parseCommaList, parseOptCommaList,-        showFilePath, showToken, showTestedWith, showFreeText, parseFreeText,-        field, simpleField, listField, spaceListField, commaListField,-        optsField, liftField, boolField, parseQuoted,--        UnrecFieldParser, warnUnrec, ignoreUnrec,-  ) where--import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat)-import Distribution.License-import Distribution.Version-         ( Version(..), VersionRange, anyVersion )-import Distribution.Package     ( PackageName(..), Dependency(..) )-import Distribution.ModuleName (ModuleName)-import Distribution.Compat.ReadP as ReadP hiding (get)-import Distribution.ReadE-import Distribution.Text-         ( Text(..) )-import Distribution.Simple.Utils-         ( comparing, intercalate, lowercase, normaliseLineEndings )-import Language.Haskell.Extension-         ( Language, Extension )--import Text.PrettyPrint hiding (braces)-import Data.Char (isSpace, toLower, isAlphaNum, isDigit)-import Data.Maybe       (fromMaybe)-import Data.Tree as Tree (Tree(..), flatten)-import qualified Data.Map as Map-import Control.Monad (foldM)-import System.FilePath (normalise)-import Data.List (sortBy)---- -------------------------------------------------------------------------------type LineNo = Int--data PError = AmbigousParse String LineNo-            | NoParse String LineNo-            | TabsError LineNo-            | FromString String (Maybe LineNo)-        deriving Show--data PWarning = PWarning String-              | UTFWarning LineNo String-        deriving Show--showPWarning :: FilePath -> PWarning -> String-showPWarning fpath (PWarning msg) =-  normalise fpath ++ ": " ++ msg-showPWarning fpath (UTFWarning line fname) =-  normalise fpath ++ ":" ++ show line-        ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field."--data ParseResult a = ParseFailed PError | ParseOk [PWarning] a-        deriving Show--instance Monad ParseResult where-        return x = ParseOk [] x-        ParseFailed err >>= _ = ParseFailed err-        ParseOk ws x >>= f = case f x of-                               ParseFailed err -> ParseFailed err-                               ParseOk ws' x' -> ParseOk (ws'++ws) x'-        fail s = ParseFailed (FromString s Nothing)--catchParseError :: ParseResult a -> (PError -> ParseResult a)-                -> ParseResult a-p@(ParseOk _ _) `catchParseError` _ = p-ParseFailed e `catchParseError` k   = k e--parseFail :: PError -> ParseResult a-parseFail = ParseFailed--runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a-runP line fieldname p s =-  case [ x | (x,"") <- results ] of-    [a] -> ParseOk (utf8Warnings line fieldname s) a-    --TODO: what is this double parse thing all about?-    --      Can't we just do the all isSpace test the first time?-    []  -> case [ x | (x,ys) <- results, all isSpace ys ] of-             [a] -> ParseOk (utf8Warnings line fieldname s) a-             []  -> ParseFailed (NoParse fieldname line)-             _   -> ParseFailed (AmbigousParse fieldname line)-    _   -> ParseFailed (AmbigousParse fieldname line)-  where results = readP_to_S p s--runE :: LineNo -> String -> ReadE a -> String -> ParseResult a-runE line fieldname p s =-    case runReadE p s of-      Right a -> ParseOk (utf8Warnings line fieldname s) a-      Left  e -> syntaxError line $-        "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s--utf8Warnings :: LineNo -> String -> String -> [PWarning]-utf8Warnings line fieldname s =-  take 1 [ UTFWarning n fieldname-         | (n,l) <- zip [line..] (lines s)-         , '\xfffd' `elem` l ]--locatedErrorMsg :: PError -> (Maybe LineNo, String)-locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'.")-locatedErrorMsg (NoParse f n)       = (Just n, "Parse of field '"++f++"' failed.")-locatedErrorMsg (TabsError n)       = (Just n, "Tab used as indentation.")-locatedErrorMsg (FromString s n)    = (n, s)--syntaxError :: LineNo -> String -> ParseResult a-syntaxError n s = ParseFailed $ FromString s (Just n)--tabsError :: LineNo -> ParseResult a-tabsError ln = ParseFailed $ TabsError ln--warning :: String -> ParseResult ()-warning s = ParseOk [PWarning s] ()---- | Field descriptor.  The parameter @a@ parameterizes over where the field's---   value is stored in.-data FieldDescr a-  = FieldDescr-      { fieldName     :: String-      , fieldGet      :: a -> Doc-      , fieldSet      :: LineNo -> String -> a -> ParseResult a-        -- ^ @fieldSet n str x@ Parses the field value from the given input-        -- string @str@ and stores the result in @x@ if the parse was-        -- successful.  Otherwise, reports an error on line number @n@.-      }--field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a-field name showF readF =-  FieldDescr name showF (\line val _st -> runP line name readF val)---- Lift a field descriptor storing into an 'a' to a field descriptor storing--- into a 'b'.-liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b-liftField get set (FieldDescr name showF parseF)- = FieldDescr name (\b -> showF (get b))-        (\line str b -> do-            a <- parseF line str (get b)-            return (set a b))---- Parser combinator for simple fields.  Takes a field name, a pretty printer,--- a parser function, an accessor, and a setter, returns a FieldDescr over the--- compoid structure.-simpleField :: String -> (a -> Doc) -> (ReadP a a)-            -> (b -> a) -> (a -> b -> b) -> FieldDescr b-simpleField name showF readF get set-  = liftField get set $ field name showF readF--commaListField :: String -> (a -> Doc) -> (ReadP [a] a)-                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-commaListField name showF readF get set =-  liftField get set' $-    field name (fsep . punctuate comma . map showF) (parseCommaList readF)-  where-    set' xs b = set (get b ++ xs) b--spaceListField :: String -> (a -> Doc) -> (ReadP [a] a)-                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-spaceListField name showF readF get set =-  liftField get set' $-    field name (fsep . map showF) (parseSpaceList readF)-  where-    set' xs b = set (get b ++ xs) b--listField :: String -> (a -> Doc) -> (ReadP [a] a)-                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-listField name showF readF get set =-  liftField get set' $-    field name (fsep . map showF) (parseOptCommaList readF)-  where-    set' xs b = set (get b ++ xs) b--optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b-optsField name flavor get set =-   liftField (fromMaybe [] . lookup flavor . get)-             (\opts b -> set (reorder (update flavor opts (get b))) b) $-        field name (hsep . map text)-                   (sepBy parseTokenQ' (munch1 isSpace))-  where-        update _ opts l | all null opts = l  --empty opts as if no opts-        update f opts [] = [(f,opts)]-        update f opts ((f',opts'):rest)-           | f == f'   = (f, opts' ++ opts) : rest-           | otherwise = (f',opts') : update f opts rest-        reorder = sortBy (comparing fst)---- TODO: this is a bit smelly hack. It's because we want to parse bool fields---       liberally but not accept new parses. We cannot do that with ReadP---       because it does not support warnings. We need a new parser framwork!-boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b-boolField name get set = liftField get set (FieldDescr name showF readF)-  where-    showF = text . show-    readF line str _-      |  str == "True"  = ParseOk [] True-      |  str == "False" = ParseOk [] False-      | lstr == "true"  = ParseOk [caseWarning] True-      | lstr == "false" = ParseOk [caseWarning] False-      | otherwise       = ParseFailed (NoParse name line)-      where-        lstr = lowercase str-        caseWarning = PWarning $-          "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'."--ppFields :: [FieldDescr a] -> a -> Doc-ppFields fields x = vcat [ ppField name (getter x)-                         | FieldDescr name getter _ <- fields]--ppField :: String -> Doc -> Doc-ppField name fielddoc = text name <> colon <+> fielddoc--showFields :: [FieldDescr a] -> a -> String-showFields fields = render . ($+$ text "") . ppFields fields--showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)-showSingleNamedField fields f =-  case [ get | (FieldDescr f' get _) <- fields, f' == f ] of-    []      -> Nothing-    (get:_) -> Just (render . ppField f . get)--parseFields :: [FieldDescr a] -> a -> String -> ParseResult a-parseFields fields initial = \str ->-  readFields str >>= accumFields fields initial--parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a-parseFieldsFlat fields initial = \str ->-  readFieldsFlat str >>= accumFields fields initial--accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a-accumFields fields = foldM setField-  where-    fieldMap = Map.fromList-      [ (name, f) | f@(FieldDescr name _ _) <- fields ]-    setField accum (F line name value) = case Map.lookup name fieldMap of-      Just (FieldDescr _ _ set) -> set line value accum-      Nothing -> do-        warning ("Unrecognized field " ++ name ++ " on line " ++ show line)-        return accum-    setField accum f = do-      warning ("Unrecognized stanza on line " ++ show (lineNo f))-      return accum---- | The type of a function which, given a name-value pair of an---   unrecognized field, and the current structure being built,---   decides whether to incorporate the unrecognized field---   (by returning  Just x, where x is a possibly modified version---   of the structure being built), or not (by returning Nothing).-type UnrecFieldParser a = (String,String) -> a -> Maybe a---- | A default unrecognized field parser which simply returns Nothing,---   i.e. ignores all unrecognized fields, so warnings will be generated.-warnUnrec :: UnrecFieldParser a-warnUnrec _ _ = Nothing---- | A default unrecognized field parser which silently (i.e. no---   warnings will be generated) ignores unrecognized fields, by---   returning the structure being built unmodified.-ignoreUnrec :: UnrecFieldParser a-ignoreUnrec _ x = Just x------------------------------------------------------------------------------------ The data type for our three syntactic categories-data Field-    = F LineNo String String-      -- ^ A regular @<property>: <value>@ field-    | Section LineNo String String [Field]-      -- ^ A section with a name and possible parameter.  The syntactic-      -- structure is:-      ---      -- @-      --   <sectionname> <arg> {-      --     <field>*-      --   }-      -- @-    | IfBlock LineNo String [Field] [Field]-      -- ^ A conditional block with an optional else branch:-      ---      -- @-      --  if <condition> {-      --    <field>*-      --  } else {-      --    <field>*-      --  }-      -- @-      deriving (Show-               ,Eq)   -- for testing--lineNo :: Field -> LineNo-lineNo (F n _ _) = n-lineNo (Section n _ _ _) = n-lineNo (IfBlock n _ _ _) = n--fName :: Field -> String-fName (F _ n _) = n-fName (Section _ n _ _) = n-fName _ = error "fname: not a field or section"--readFields :: String -> ParseResult [Field]-readFields input = ifelse-               =<< mapM (mkField 0)-               =<< mkTree tokens--  where ls = (lines . normaliseLineEndings) input-        tokens = (concatMap tokeniseLine . trimLines) ls--readFieldsFlat :: String -> ParseResult [Field]-readFieldsFlat input = mapM (mkField 0)-                   =<< mkTree tokens-  where ls = (lines . normaliseLineEndings) input-        tokens = (concatMap tokeniseLineFlat . trimLines) ls---- attach line number and determine indentation-trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)]-trimLines ls = [ (lineno, indent, hastabs, (trimTrailing l'))-               | (lineno, l) <- zip [1..] ls-               , let (sps, l') = span isSpace l-                     indent    = length sps-                     hastabs   = '\t' `elem` sps-               , validLine l' ]-  where validLine ('-':'-':_) = False      -- Comment-        validLine []          = False      -- blank line-        validLine _           = True---- | We parse generically based on indent level and braces '{' '}'. To do that--- we split into lines and then '{' '}' tokens and other spans within a line.-data Token =-       -- | The 'Line' token is for bits that /start/ a line, eg:-       ---       -- > "\n  blah blah { blah"-       ---       -- tokenises to:-       ---       -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"]-       ---       -- so lines are the only ones that can have nested layout, since they-       -- have a known indentation level.-       ---       -- eg: we can't have this:-       ---       -- > if ... {-       -- > } else-       -- >     other-       ---       -- because other cannot nest under else, since else doesn't start a line-       -- so cannot have nested layout. It'd have to be:-       ---       -- > if ... {-       -- > }-       -- >   else-       -- >     other-       ---       -- but that's not so common, people would normally use layout or-       -- brackets not both in a single @if else@ construct.-       ---       -- > if ... { foo : bar }-       -- > else-       -- >    other-       ---       -- this is ok-       Line LineNo Indent HasTabs String-     | Span LineNo                String  -- ^ span in a line, following brackets-     | OpenBracket LineNo | CloseBracket LineNo--type Indent = Int-type HasTabs = Bool---- | Tokenise a single line, splitting on '{' '}' and the spans inbetween.--- Also trims leading & trailing space on those spans within the line.-tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token]-tokeniseLine (n0, i, t, l) = case split n0 l of-                            (Span _ l':ss) -> Line n0 i t l' :ss-                            cs              -> cs-  where split _ "" = []-        split n s  = case span (\c -> c /='}' && c /= '{') s of-          ("", '{' : s') ->             OpenBracket  n : split n s'-          (w , '{' : s') -> mkspan n w (OpenBracket  n : split n s')-          ("", '}' : s') ->             CloseBracket n : split n s'-          (w , '}' : s') -> mkspan n w (CloseBracket n : split n s')-          (w ,        _) -> mkspan n w []--        mkspan n s ss | null s'   =             ss-                      | otherwise = Span n s' : ss-          where s' = trimTrailing (trimLeading s)--tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token]-tokeniseLineFlat (n0, i, t, l)-  | null l'   = []-  | otherwise = [Line n0 i t l']-  where-    l' = trimTrailing (trimLeading l)--trimLeading, trimTrailing :: String -> String-trimLeading  = dropWhile isSpace-trimTrailing = reverse . dropWhile isSpace . reverse---type SyntaxTree = Tree (LineNo, HasTabs, String)---- | Parse the stream of tokens into a tree of them, based on indent \/ layout-mkTree :: [Token] -> ParseResult [SyntaxTree]-mkTree toks =-  layout 0 [] toks >>= \(trees, trailing) -> case trailing of-    []               -> return trees-    OpenBracket  n:_ -> syntaxError n "mismatched backets, unexpected {"-    CloseBracket n:_ -> syntaxError n "mismatched backets, unexpected }"-    -- the following two should never happen:-    Span n     l  :_ -> syntaxError n $ "unexpected span: " ++ show l-    Line n _ _ l  :_ -> syntaxError n $ "unexpected line: " ++ show l----- | Parse the stream of tokens into a tree of them, based on indent--- This parse state expect to be in a layout context, though possibly--- nested within a braces context so we may still encounter closing braces.-layout :: Indent       -- ^ indent level of the parent\/previous line-       -> [SyntaxTree] -- ^ accumulating param, trees in this level-       -> [Token]      -- ^ remaining tokens-       -> ParseResult ([SyntaxTree], [Token])-                       -- ^ collected trees on this level and trailing tokens-layout _ a []                               = return (reverse a, [])-layout i a (s@(Line _ i' _ _):ss) | i' < i  = return (reverse a, s:ss)-layout i a (Line n _ t l:OpenBracket n':ss) = do-    (sub, ss') <- braces n' [] ss-    layout i (Node (n,t,l) sub:a) ss'--layout i a (Span n     l:OpenBracket n':ss) = do-    (sub, ss') <- braces n' [] ss-    layout i (Node (n,False,l) sub:a) ss'---- look ahead to see if following lines are more indented, giving a sub-tree-layout i a (Line n i' t l:ss) = do-    lookahead <- layout (i'+1) [] ss-    case lookahead of-        ([], _)   -> layout i (Node (n,t,l) [] :a) ss-        (ts, ss') -> layout i (Node (n,t,l) ts :a) ss'--layout _ _ (   OpenBracket  n :_)  = syntaxError n $ "unexpected '{'"-layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss)-layout _ _ (   Span n l       : _) = syntaxError n $ "unexpected span: "-                                                  ++ show l---- | Parse the stream of tokens into a tree of them, based on explicit braces--- This parse state expects to find a closing bracket.-braces :: LineNo       -- ^ line of the '{', used for error messages-       -> [SyntaxTree] -- ^ accumulating param, trees in this level-       -> [Token]      -- ^ remaining tokens-       -> ParseResult ([SyntaxTree],[Token])-                       -- ^ collected trees on this level and trailing tokens-braces m a (Line n _ t l:OpenBracket n':ss) = do-    (sub, ss') <- braces n' [] ss-    braces m (Node (n,t,l) sub:a) ss'--braces m a (Span n     l:OpenBracket n':ss) = do-    (sub, ss') <- braces n' [] ss-    braces m (Node (n,False,l) sub:a) ss'--braces m a (Line n i t l:ss) = do-    lookahead <- layout (i+1) [] ss-    case lookahead of-        ([], _)   -> braces m (Node (n,t,l) [] :a) ss-        (ts, ss') -> braces m (Node (n,t,l) ts :a) ss'--braces m a (Span n       l:ss) = braces m (Node (n,False,l) []:a) ss-braces _ a (CloseBracket _:ss) = return (reverse a, ss)-braces n _ []                  = syntaxError n $ "opening brace '{'"-                              ++ "has no matching closing brace '}'"-braces _ _ (OpenBracket  n:_)  = syntaxError n "unexpected '{'"---- | Convert the parse tree into the Field AST--- Also check for dodgy uses of tabs in indentation.-mkField :: Int -> SyntaxTree -> ParseResult Field-mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n-mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of-  ([], _)       -> syntaxError n $ "unrecognised field or section: " ++ show l-  (name, rest)  -> case trimLeading rest of-    (':':rest') -> do let followingLines = concatMap Tree.flatten ts-                          tabs = not (null [()| (_,True,_) <- followingLines ])-                      if tabs && d >= 1-                        then tabsError n-                        else return $ F n (map toLower name)-                                          (fieldValue rest' followingLines)-    rest'       -> do ts' <- mapM (mkField (d+1)) ts-                      return (Section n (map toLower name) rest' ts')- where    fieldValue firstLine followingLines =-            let firstLine' = trimLeading firstLine-                followingLines' = map (\(_,_,s) -> stripDot s) followingLines-                allLines | null firstLine' =              followingLines'-                         | otherwise       = firstLine' : followingLines'-             in intercalate "\n" allLines-          stripDot "." = ""-          stripDot s   = s---- | Convert if/then/else 'Section's to 'IfBlock's-ifelse :: [Field] -> ParseResult [Field]-ifelse [] = return []-ifelse (Section n "if"   cond thenpart-       :Section _ "else" as   elsepart:fs)-       | null cond     = syntaxError n "'if' with missing condition"-       | null thenpart = syntaxError n "'then' branch of 'if' is empty"-       | not (null as) = syntaxError n "'else' takes no arguments"-       | null elsepart = syntaxError n "'else' branch of 'if' is empty"-       | otherwise     = do tp  <- ifelse thenpart-                            ep  <- ifelse elsepart-                            fs' <- ifelse fs-                            return (IfBlock n cond tp ep:fs')-ifelse (Section n "if"   cond thenpart:fs)-       | null cond     = syntaxError n "'if' with missing condition"-       | null thenpart = syntaxError n "'then' branch of 'if' is empty"-       | otherwise     = do tp  <- ifelse thenpart-                            fs' <- ifelse fs-                            return (IfBlock n cond tp []:fs')-ifelse (Section n "else" _ _:_) = syntaxError n "stray 'else' with no preceding 'if'"-ifelse (Section n s a fs':fs) = do fs''  <- ifelse fs'-                                   fs''' <- ifelse fs-                                   return (Section n s a fs'' : fs''')-ifelse (f:fs) = do fs' <- ifelse fs-                   return (f : fs')------------------------------------------------------------------------------------ |parse a module name-parseModuleNameQ :: ReadP r ModuleName-parseModuleNameQ = parseQuoted parse <++ parse--parseFilePathQ :: ReadP r FilePath-parseFilePathQ = parseTokenQ-  -- removed until normalise is no longer broken, was:-  --   liftM normalise parseTokenQ--parseBuildTool :: ReadP r Dependency-parseBuildTool = do name <- parseBuildToolNameQ-                    skipSpaces-                    ver <- parseVersionRangeQ <++ return anyVersion-                    skipSpaces-                    return $ Dependency name ver--parseBuildToolNameQ :: ReadP r PackageName-parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName---- like parsePackageName but accepts symbols in components-parseBuildToolName :: ReadP r PackageName-parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-')-                        return (PackageName (intercalate "-" ns))-  where component = do-          cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_')-          if all isDigit cs then pfail else return cs---- 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-parsePkgconfigDependency :: ReadP r Dependency-parsePkgconfigDependency = do name <- munch1 (\c -> isAlphaNum c || c `elem` "+-._")-                              skipSpaces-                              ver <- parseVersionRangeQ <++ return anyVersion-                              skipSpaces-                              return $ Dependency (PackageName name) ver--parsePackageNameQ :: ReadP r PackageName-parsePackageNameQ = parseQuoted parse <++ parse--parseVersionRangeQ :: ReadP r VersionRange-parseVersionRangeQ = parseQuoted parse <++ parse--parseOptVersion :: ReadP r Version-parseOptVersion = parseQuoted ver <++ ver-  where ver :: ReadP r Version-        ver = parse <++ return noVersion-        noVersion = Version{ versionBranch=[], versionTags=[] }--parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange)-parseTestedWithQ = parseQuoted tw <++ tw-  where-    tw :: ReadP r (CompilerFlavor,VersionRange)-    tw = do compiler <- parseCompilerFlavorCompat-            skipSpaces-            version <- parse <++ return anyVersion-            skipSpaces-            return (compiler,version)--parseLicenseQ :: ReadP r License-parseLicenseQ = parseQuoted parse <++ parse---- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a--- because the "compat" version of ReadP isn't quite powerful enough.  In--- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a--- Hence the trick above to make 'lic' polymorphic.--parseLanguageQ :: ReadP r Language-parseLanguageQ = parseQuoted parse <++ parse--parseExtensionQ :: ReadP r Extension-parseExtensionQ = parseQuoted parse <++ parse--parseHaskellString :: ReadP r String-parseHaskellString = readS_to_P reads--parseTokenQ :: ReadP r String-parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',')--parseTokenQ' :: ReadP r String-parseTokenQ' = parseHaskellString <++ munch1 (\x -> not (isSpace x))--parseSepList :: ReadP r b-             -> ReadP r a -- ^The parser for the stuff between commas-             -> ReadP r [a]-parseSepList sepr p = sepBy p separator-    where separator = skipSpaces >> sepr >> skipSpaces--parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas-               -> ReadP r [a]-parseSpaceList p = sepBy p skipSpaces--parseCommaList :: ReadP r a -- ^The parser for the stuff between commas-               -> ReadP r [a]-parseCommaList = parseSepList (ReadP.char ',')--parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas-                  -> ReadP r [a]-parseOptCommaList = parseSepList (optional (ReadP.char ','))--parseQuoted :: ReadP r a -> ReadP r a-parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p--parseFreeText :: ReadP.ReadP s String-parseFreeText = ReadP.munch (const True)---- ----------------------------------------------- ** Pretty printing--showFilePath :: FilePath -> Doc-showFilePath = showToken--showToken :: String -> Doc-showToken str- | not (any dodgy str) &&-   not (null str)       = text str- | otherwise            = text (show str)-  where dodgy c = isSpace c || c == ','--showTestedWith :: (CompilerFlavor,VersionRange) -> Doc-showTestedWith (compiler, version) = text (show compiler) <+> disp version---- | Pretty-print free-format text, ensuring that it is vertically aligned,--- and with blank lines replaced by dots for correct re-parsing.-showFreeText :: String -> Doc-showFreeText "" = empty-showFreeText ('\n' :r)  = text " " $+$ text "." $+$ showFreeText r-showFreeText s  = vcat [text (if null l then "." else 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''
− Distribution/ReadE.hs 
@@ -1,81 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.ReadE--- Copyright   :  Jose Iborra 2008------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Simple parsing with failure--{- Copyright (c) 2007, Jose Iborra-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.ReadE (-   -- * ReadE-   ReadE(..), succeedReadE, failReadE,-   -- * Projections-   parseReadE, readEOrFail,-   readP_to_E-  ) where--import Distribution.Compat.ReadP-import Data.Char ( isSpace )---- | Parser with simple error reporting-newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a}-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--succeedReadE :: (String -> a) -> ReadE a-succeedReadE f = ReadE (Right . f)--failReadE :: ErrorMsg -> ReadE a-failReadE = ReadE . const Left--parseReadE :: ReadE a -> ReadP r a-parseReadE (ReadE p) = do-  txt <- look-  either fail return (p txt)--readEOrFail :: ReadE a -> (String -> a)-readEOrFail r = either error id . runReadE r--readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a-readP_to_E err r =-    ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt-                         , all isSpace s ]-                    of [] -> Left (err txt)-                       (p:_) -> Right p
− Distribution/Simple.hs 
@@ -1,703 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple--- Copyright   :  Isaac Jones 2003-2005------ 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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--{--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,-        -- ** Standard sets of hooks-        simpleUserHooks,-        autoconfUserHooks,-        defaultUserHooks, emptyUserHooks,-        -- ** Utils-        defaultHookedPackageDesc-  ) where---- local-import Distribution.Simple.Compiler hiding (Flag)-import Distribution.Simple.UserHooks-import Distribution.Package --must not specify imports, since we're exporting moule.-import Distribution.PackageDescription-         ( PackageDescription(..), GenericPackageDescription, Executable(..)-         , updatePackageDescription, hasLibs-         , HookedBuildInfo, emptyHookedBuildInfo )-import Distribution.PackageDescription.Parse-         ( readPackageDescription, readHookedBuildInfo )-import Distribution.PackageDescription.Configuration-         ( flattenPackageDescription )-import Distribution.Simple.Program-         ( defaultProgramConfiguration, addKnownPrograms, builtinPrograms-         , restoreProgramConfiguration, reconfigurePrograms )-import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler)-import Distribution.Simple.Setup-import Distribution.Simple.Command--import Distribution.Simple.Build        ( build )-import Distribution.Simple.SrcDist      ( sdist )-import Distribution.Simple.Register-         ( register, unregister )--import Distribution.Simple.Configure-         ( getPersistBuildConfig, maybeGetPersistBuildConfig-         , writePersistBuildConfig, checkPersistBuildConfigOutdated-         , configure, checkForeignDeps )--import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )-import Distribution.Simple.Bench (bench)-import Distribution.Simple.BuildPaths ( srcPref)-import Distribution.Simple.Test (test)-import Distribution.Simple.Install (install)-import Distribution.Simple.Haddock (haddock, hscolour)-import Distribution.Simple.Utils-         (die, notice, info, warn, setupMessage, chattyTry,-          defaultPackageDesc, defaultHookedPackageDesc,-          rawSystemExitWithEnv, cabalVersion, topHandler )-import Distribution.System-         ( OS(..), buildOS )-import Distribution.Verbosity-import Language.Haskell.Extension-import Distribution.Version-import Distribution.License-import Distribution.Text-         ( display )---- Base-import System.Environment(getArgs, getProgName, getEnvironment)-import System.Directory(removeFile, doesFileExist,-                        doesDirectoryExist, removeDirectoryRecursive)-import System.Exit-import System.IO.Error   (isDoesNotExistError)-import Distribution.Compat.Exception (catchIO, throwIOIO)--import Control.Monad   (when)-import Data.List       (intersperse, unionBy, nub, (\\))---- | 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 pkg_descr =-  getArgs >>=-  defaultMainHelper simpleUserHooks { readDesc = return (Just pkg_descr) }--defaultMainHelper :: UserHooks -> Args -> IO ()-defaultMainHelper hooks args = topHandler $-  case commandsRun globalCommand 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 (concat (intersperse "\n" errs))-      exitWith (ExitFailure 1)-    printNumericVersion = putStrLn $ display cabalVersion-    printVersion        = putStrLn $ "Cabal library version "-                                  ++ display cabalVersion--    progs = addKnownPrograms (hookedPrograms hooks) defaultProgramConfiguration-    commands =-      [configureCommand progs `commandAddAction` \fs as ->-                                                 configureAction    hooks fs as >> return ()-      ,buildCommand     progs `commandAddAction` buildAction        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-                let distPref = fromFlag $ configDistPref flags-                pbi <- preConf hooks args flags--                (mb_pd_file, pkg_descr0) <- confPkgDescr--                --    get_pkg_descr (configVerbosity flags')-                --let pkg_descr = updatePackageDescription pbi pkg_descr0-                let epkg_descr = (pkg_descr0, pbi)--                --(warns, ers) <- sanityCheckPackage pkg_descr-                --errorOut (configVerbosity flags') warns ers--                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 :: IO (Maybe FilePath, GenericPackageDescription)-                confPkgDescr = do-                  mdescr <- readDesc hooks-                  case mdescr of-                    Just descr -> return (Nothing, descr)-                    Nothing -> do-                      pdfile <- defaultPackageDesc verbosity-                      descr  <- readPackageDescription verbosity pdfile-                      return (Just pdfile, descr)--buildAction :: UserHooks -> BuildFlags -> Args -> IO ()-buildAction hooks flags args = do-  let distPref  = fromFlag $ buildDistPref flags-      verbosity = fromFlag $ buildVerbosity flags--  lbi <- getBuildConfig hooks verbosity distPref-  progs <- reconfigurePrograms verbosity-             (buildProgramPaths flags)-             (buildProgramArgs flags)-             (withPrograms lbi)--  hookedAction preBuild buildHook postBuild-               (return lbi { withPrograms = progs })-               hooks flags args--hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO ()-hscolourAction hooks flags args-    = do let distPref  = fromFlag $ hscolourDistPref flags-             verbosity = fromFlag $ hscolourVerbosity flags-         hookedAction preHscolour hscolourHook postHscolour-                      (getBuildConfig hooks verbosity distPref)-                      hooks flags args--haddockAction :: UserHooks -> HaddockFlags -> Args -> IO ()-haddockAction hooks flags args = do-  let distPref  = fromFlag $ haddockDistPref flags-      verbosity = fromFlag $ haddockVerbosity flags--  lbi <- getBuildConfig hooks verbosity distPref-  progs <- reconfigurePrograms verbosity-             (haddockProgramPaths flags)-             (haddockProgramArgs flags)-             (withPrograms lbi)--  hookedAction preHaddock haddockHook postHaddock-               (return lbi { withPrograms = progs })-               hooks flags args--cleanAction :: UserHooks -> CleanFlags -> Args -> IO ()-cleanAction hooks flags args = do-                pbi <- preClean hooks args flags--                pdfile <- defaultPackageDesc verbosity-                ppd <- readPackageDescription verbosity pdfile-                let pkg_descr0 = flattenPackageDescription ppd-                -- We don't sanity check for clean as an error-                -- here would prevent cleaning:-                --sanityCheckHookedBuildInfo 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 let distPref  = fromFlag $ copyDistPref flags-             verbosity = fromFlag $ copyVerbosity flags-         hookedAction preCopy copyHook postCopy-                      (getBuildConfig hooks verbosity distPref)-                      hooks flags args--installAction :: UserHooks -> InstallFlags -> Args -> IO ()-installAction hooks flags args-    = do let distPref  = fromFlag $ installDistPref flags-             verbosity = fromFlag $ installVerbosity flags-         hookedAction preInst instHook postInst-                      (getBuildConfig hooks verbosity distPref)-                      hooks flags args--sdistAction :: UserHooks -> SDistFlags -> Args -> IO ()-sdistAction hooks flags args = do-                let distPref = fromFlag $ sDistDistPref flags-                pbi <- preSDist hooks args flags--                mlbi <- maybeGetPersistBuildConfig distPref-                pdfile <- defaultPackageDesc verbosity-                ppd <- readPackageDescription verbosity pdfile-                let pkg_descr0 = flattenPackageDescription ppd-                sanityCheckHookedBuildInfo pkg_descr0 pbi-                let pkg_descr = updatePackageDescription pbi pkg_descr0--                sDistHook hooks pkg_descr mlbi hooks flags-                postSDist hooks args flags pkg_descr mlbi-  where verbosity = fromFlag (sDistVerbosity flags)--testAction :: UserHooks -> TestFlags -> Args -> IO ()-testAction hooks flags args = do-    let distPref  = fromFlag $ testDistPref flags-        verbosity = fromFlag $ testVerbosity flags-    localBuildInfo <- getBuildConfig hooks verbosity distPref-    let pkg_descr = localPkgDescr localBuildInfo-    -- It is safe to do 'runTests' before the new test handler because the-    -- default action is a no-op and if the package uses the old test interface-    -- the new handler will find no tests.-    runTests hooks args False pkg_descr localBuildInfo-    --FIXME: this is a hack, passing the args inside the flags-    -- it's because the args to not get passed to the main test hook-    let flags' = flags { testList = Flag args }-    hookedAction preTest testHook postTest-            (getBuildConfig hooks verbosity distPref)-            hooks flags' args--benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO ()-benchAction hooks flags args = do-    let distPref  = fromFlag $ benchmarkDistPref flags-        verbosity = fromFlag $ benchmarkVerbosity flags-    hookedActionWithArgs preBench benchHook postBench-            (getBuildConfig hooks verbosity distPref)-            hooks flags args--registerAction :: UserHooks -> RegisterFlags -> Args -> IO ()-registerAction hooks flags args-    = do let distPref  = fromFlag $ regDistPref flags-             verbosity = fromFlag $ regVerbosity flags-         hookedAction preReg regHook postReg-                      (getBuildConfig hooks verbosity distPref)-                      hooks flags args--unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO ()-unregisterAction hooks flags args-    = do let distPref  = fromFlag $ regDistPref flags-             verbosity = fromFlag $ regVerbosity flags-         hookedAction preUnreg unregHook postUnreg-                      (getBuildConfig hooks verbosity distPref)-                      hooks flags args--hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo)-        -> (UserHooks -> PackageDescription -> LocalBuildInfo-                      -> UserHooks -> flags -> IO ())-        -> (UserHooks -> Args -> flags -> PackageDescription-                      -> LocalBuildInfo -> IO ())-        -> IO LocalBuildInfo-        -> UserHooks -> flags -> Args -> IO ()-hookedAction pre_hook cmd_hook =-    hookedActionWithArgs pre_hook (\h _ pd lbi uh flags -> cmd_hook h pd lbi uh flags)--hookedActionWithArgs :: (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 pre_hook cmd_hook post_hook get_build_config hooks flags args = do-   pbi <- pre_hook hooks args flags-   localbuildinfo <- get_build_config-   let pkg_descr0 = localPkgDescr localbuildinfo-   --pkg_descr0 <- get_pkg_descr (get_verbose flags)-   sanityCheckHookedBuildInfo pkg_descr0 pbi-   let pkg_descr = updatePackageDescription pbi pkg_descr0-   -- TODO: should we write the modified package descr back to the-   -- localbuildinfo?-   cmd_hook hooks args pkg_descr localbuildinfo hooks flags-   post_hook hooks args flags pkg_descr localbuildinfo--sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO ()-sanityCheckHookedBuildInfo PackageDescription { library = Nothing } (Just _,_)-    = die $ "The buildinfo contains info for a library, "-         ++ "but the package does not have a library."--sanityCheckHookedBuildInfo pkg_descr (_, hookExes)-    | not (null nonExistant)-    = die $ "The buildinfo contains info for an executable called '"-         ++ head nonExistant ++ "' 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 ()---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 = restoreProgramConfiguration-                     (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 conigure run:-            configPrograms = restoreProgramConfiguration-                               (builtinPrograms ++ hookedPrograms hooks)-                               (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 = fromFlag $ 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-    mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr)--    -- If the user wanted to save the config, write it back-    maybe (return ()) (writePersistBuildConfig distPref) maybeConfig--  where-        removeFileOrDirectory :: FilePath -> IO ()-        removeFileOrDirectory fname = do-            isDir <- doesDirectoryExist fname-            isFile <- doesFileExist fname-            if isDir then removeDirectoryRecursive fname-              else if isFile then removeFile fname-              else return ()-        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,-       copyHook  = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params-       testHook = defaultTestHook,-       benchHook = defaultBenchHook,-       instHook  = defaultInstallHook,-       sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h),-       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.--{-# DEPRECATED defaultUserHooks-     "Use simpleUserHooks or autoconfUserHooks, unless you need Cabal-1.2\n             compatibility in which case you must stick with defaultUserHooks" #-}-defaultUserHooks :: UserHooks-defaultUserHooks = autoconfUserHooks {-          confHook = \pkg flags -> do-                       let verbosity = fromFlag (configVerbosity flags)-                       warn verbosity $-                         "defaultUserHooks in Setup script is deprecated."-                       confHook autoconfUserHooks pkg flags,-          postConf = oldCompatPostConf-    }-    -- This is the annoying old version that only runs configure if it exists.-    -- It's here for compatibility with existing Setup.hs scripts. See:-    -- http://hackage.haskell.org/trac/hackage/ticket/165-    where oldCompatPostConf args flags pkg_descr lbi-              = do let verbosity = fromFlag (configVerbosity flags)-                   noExtraFlags args-                   confExists <- doesFileExist "configure"-                   when confExists $-                       runConfigureScript verbosity-                         backwardsCompatHack flags lbi--                   pbi <- getHookedBuildInfo verbosity-                   sanityCheckHookedBuildInfo pkg_descr pbi-                   let pkg_descr' = updatePackageDescription pbi pkg_descr-                   postConf simpleUserHooks args flags pkg_descr' lbi--          backwardsCompatHack = True--autoconfUserHooks :: UserHooks-autoconfUserHooks-    = simpleUserHooks-      {-       postConf    = defaultPostConf,-       preBuild    = readHook buildVerbosity,-       preClean    = readHook cleanVerbosity,-       preCopy     = readHook copyVerbosity,-       preInst     = readHook installVerbosity,-       preHscolour = readHook hscolourVerbosity,-       preHaddock  = readHook haddockVerbosity,-       preReg      = readHook regVerbosity,-       preUnreg    = readHook regVerbosity-      }-    where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()-          defaultPostConf args flags pkg_descr lbi-              = do let verbosity = fromFlag (configVerbosity flags)-                   noExtraFlags args-                   confExists <- doesFileExist "configure"-                   if confExists-                     then runConfigureScript verbosity-                            backwardsCompatHack flags lbi-                     else die "configure script not found."--                   pbi <- getHookedBuildInfo verbosity-                   sanityCheckHookedBuildInfo pkg_descr pbi-                   let pkg_descr' = updatePackageDescription pbi pkg_descr-                   postConf simpleUserHooks args flags pkg_descr' lbi--          backwardsCompatHack = False--          readHook :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo-          readHook get_verbosity a flags = do-              noExtraFlags a-              getHookedBuildInfo verbosity-            where-              verbosity = fromFlag (get_verbosity flags)--runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo-                   -> IO ()-runConfigureScript verbosity backwardsCompatHack flags lbi = do--  env <- getEnvironment-  let programConfig = withPrograms lbi-  (ccProg, ccFlags) <- configureCCompiler verbosity programConfig-  -- 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-  let env' = appendToEnvironment ("CFLAGS",  unwords ccFlags)-             env-      args' = args ++ ["--with-gcc=" ++ ccProg]-  handleNoWindowsSH $-    rawSystemExitWithEnv verbosity "sh" args' env'--  where-    args = "configure" : configureArgs backwardsCompatHack flags--    appendToEnvironment (key, val) [] = [(key, val)]-    appendToEnvironment (key, val) (kv@(k, v) : rest)-     | key == k  = (key, v ++ " " ++ val) : rest-     | otherwise = kv : appendToEnvironment (key, val) rest--    handleNoWindowsSH action-      | buildOS /= Windows-      = action--      | otherwise-      = action-          `catchIO` \ioe -> if isDoesNotExistError ioe-                              then die notFoundMsg-                              else throwIOIO ioe--    notFoundMsg = "The package has a './configure' script. This requires a "-               ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin."--getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo-getHookedBuildInfo verbosity = do-  maybe_infoFile <- defaultHookedPackageDesc-  case maybe_infoFile of-    Nothing       -> return emptyHookedBuildInfo-    Just infoFile -> do-      info verbosity $ "Reading parameters from " ++ infoFile-      readHookedBuildInfo verbosity infoFile--defaultTestHook :: PackageDescription -> LocalBuildInfo-                -> UserHooks -> TestFlags -> IO ()-defaultTestHook pkg_descr localbuildinfo _ flags =-    test 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       = toFlag NoCopyDest,-                      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)--defaultRegHook :: PackageDescription -> LocalBuildInfo-        -> UserHooks -> RegisterFlags -> IO ()-defaultRegHook pkg_descr localbuildinfo _ flags =-    if hasLibs pkg_descr-    then register pkg_descr localbuildinfo flags-    else setupMessage verbosity-           "Package contains no library to register:" (packageId pkg_descr)-  where verbosity = fromFlag (regVerbosity flags)
− Distribution/Simple/Bench.hs 
@@ -1,156 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Bench--- Copyright   :  Johan Tibell 2011------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ 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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.Bench-    ( bench-    ) where--import qualified Distribution.PackageDescription as PD-    ( PackageDescription(..), BuildInfo(buildable)-    , Benchmark(..), BenchmarkInterface(..), benchmarkType, hasBenchmarks )-import Distribution.Simple.BuildPaths ( exeExtension )-import Distribution.Simple.Compiler ( Compiler(..) )-import Distribution.Simple.InstallDirs-    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)-    , substPathTemplate , toPathTemplate, PathTemplate )-import qualified Distribution.Simple.LocalBuildInfo as LBI-    ( LocalBuildInfo(..) )-import Distribution.Simple.Setup ( BenchmarkFlags(..), fromFlag )-import Distribution.Simple.UserHooks ( Args )-import Distribution.Simple.Utils ( die, notice, rawSystemExitCode )-import Distribution.Text--import Control.Monad ( when, unless )-import System.Exit ( ExitCode(..), exitFailure, exitWith )-import System.Directory ( doesFileExist )-import System.FilePath ( (</>), (<.>) )---- | Perform the \"@.\/setup bench@\" action.-bench :: Args                    -- ^positional command-line arguments-      -> PD.PackageDescription   -- ^information from the .cabal file-      -> LBI.LocalBuildInfo      -- ^information from the configure step-      -> BenchmarkFlags          -- ^flags sent to benchmark-      -> IO ()-bench args pkg_descr lbi flags = do-    let verbosity         = fromFlag $ benchmarkVerbosity flags-        benchmarkNames    = args-        pkgBenchmarks     = PD.benchmarks pkg_descr-        enabledBenchmarks = [ t | t <- pkgBenchmarks-                            , PD.benchmarkEnabled t-                            , PD.buildable (PD.benchmarkBuildInfo t) ]--        -- Run the benchmark-        doBench :: PD.Benchmark -> IO ExitCode-        doBench bm =-            case PD.benchmarkInterface bm of-              PD.BenchmarkExeV10 _ _ -> do-                  let cmd = LBI.buildDir lbi </> PD.benchmarkName bm-                            </> PD.benchmarkName bm <.> exeExtension-                      options = map (benchOption pkg_descr lbi bm) $-                                benchmarkOptions flags-                      name = PD.benchmarkName bm-                  -- Check that the benchmark executable exists.-                  exists <- doesFileExist cmd-                  unless exists $ die $-                      "Error: Could not find benchmark program \""-                      ++ cmd ++ "\". Did you build the package first?"--                  notice verbosity $ startMessage name-                  -- This will redirect the child process-                  -- stdout/stderr to the parent process.-                  exitcode <- rawSystemExitCode verbosity cmd options-                  notice verbosity $ finishMessage name exitcode-                  return exitcode--              _ -> do-                  notice verbosity $ "No support for running "-                      ++ "benchmark " ++ PD.benchmarkName bm ++ " of type: "-                      ++ show (disp $ PD.benchmarkType bm)-                  exitFailure--    when (not $ PD.hasBenchmarks pkg_descr) $ do-        notice verbosity "Package has no benchmarks."-        exitWith ExitSuccess--    when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $-        die $ "No benchmarks enabled. Did you remember to configure with "-              ++ "\'--enable-benchmarks\'?"--    bmsToRun <- case benchmarkNames of-            [] -> return enabledBenchmarks-            names -> flip mapM names $ \bmName ->-                let benchmarkMap = zip enabledNames enabledBenchmarks-                    enabledNames = map PD.benchmarkName enabledBenchmarks-                    allNames = map PD.benchmarkName pkgBenchmarks-                in case lookup bmName benchmarkMap of-                    Just t -> return t-                    _ | bmName `elem` allNames ->-                          die $ "Package configured with benchmark "-                                ++ bmName ++ " disabled."-                      | otherwise -> die $ "no such benchmark: " ++ bmName--    let totalBenchmarks = length bmsToRun-    notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."-    exitcodes <- mapM 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")----- TODO: This is abusing the notion of a 'PathTemplate'.  The result--- isn't neccesarily a path.-benchOption :: PD.PackageDescription-            -> LBI.LocalBuildInfo-            -> PD.Benchmark-            -> PathTemplate-            -> String-benchOption pkg_descr lbi bm template =-    fromPathTemplate $ substPathTemplate env template-  where-    env = initialPathTemplateEnv-          (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) ++-          [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)]
− Distribution/Simple/Build.hs 
@@ -1,338 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Build--- Copyright   :  Isaac Jones 2003-2005,---                Ross Paterson 2006,---                Duncan Coutts 2007-2008------ 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.-----{- Copyright (c) 2003-2005, Isaac Jones-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.Build (-    build,--    initialBuildSteps,-    writeAutogenFiles,-  ) where--import qualified Distribution.Simple.GHC  as GHC-import qualified Distribution.Simple.JHC  as JHC-import qualified Distribution.Simple.LHC  as LHC-import qualified Distribution.Simple.NHC  as NHC-import qualified Distribution.Simple.Hugs as Hugs-import qualified Distribution.Simple.UHC  as UHC--import qualified Distribution.Simple.Build.Macros      as Build.Macros-import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule--import Distribution.Package-         ( Package(..), PackageName(..), PackageIdentifier(..)-         , Dependency(..), thisPackageVersion )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), compilerFlavor, PackageDB(..) )-import Distribution.PackageDescription-         ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)-         , TestSuite(..), TestSuiteInterface(..), Benchmark(..)-         , BenchmarkInterface(..) )-import qualified Distribution.InstalledPackageInfo as IPI-import qualified Distribution.ModuleName as ModuleName--import Distribution.Simple.Setup-         ( BuildFlags(..), fromFlag )-import Distribution.Simple.PreProcess-         ( preprocessComponent, PPSuffixHandler )-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms)-         , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI-         , inplacePackageId )-import Distribution.Simple.Program.Types-import Distribution.Simple.Program.Db-import Distribution.Simple.BuildPaths-         ( autogenModulesDir, autogenModuleName, cppHeaderName, exeExtension )-import Distribution.Simple.Register-         ( registerPackage, inplaceInstalledPackageInfo )-import Distribution.Simple.Test ( stubFilePath, stubName )-import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, rewriteFile-         , die, info, setupMessage )--import Distribution.Verbosity-         ( Verbosity )-import Distribution.Text-         ( display )--import Data.Maybe-         ( maybeToList )-import Data.List-         ( intersect )-import Control.Monad-         ( unless )-import System.FilePath-         ( (</>), (<.>) )-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-  let distPref  = fromFlag (buildDistPref flags)-      verbosity = fromFlag (buildVerbosity flags)-  initialBuildSteps distPref pkg_descr lbi verbosity-  setupMessage verbosity "Building" (packageId pkg_descr)--  internalPackageDB <- createInternalPackageDB distPref--  let pre c lbi' = preprocessComponent pkg_descr c lbi' False verbosity suffixes-  withComponentsLBI pkg_descr lbi $ \comp clbi ->-    case comp of-      CLib lib -> do-        let bi     = libBuildInfo lib-            progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)-            lbi'   = lbi { withPrograms = progs' }-        pre comp lbi'-        info verbosity "Building library..."-        buildLib verbosity pkg_descr lbi' lib clbi--        -- Register the library in-place, so exes can depend-        -- on internally defined libraries.-        pwd <- getCurrentDirectory-        let installedPkgInfo =-              (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) {-                -- The inplace registration uses the "-inplace" suffix,-                -- not an ABI hash.-                IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo)-              }-        registerPackage verbosity-          installedPkgInfo pkg_descr lbi True -- True meaning inplace-          (withPackageDB lbi ++ [internalPackageDB])--      CExe exe -> do-        let bi     = buildInfo exe-            progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)-            lbi'   = lbi {-                       withPrograms  = progs',-                       withPackageDB = withPackageDB lbi ++ [internalPackageDB]-                     }-        pre comp lbi'-        info verbosity $ "Building executable " ++ exeName exe ++ "..."-        buildExe verbosity pkg_descr lbi' exe clbi--      CTest test -> do-        case testInterface test of-            TestSuiteExeV10 _ f -> do-                let bi  = testBuildInfo test-                    exe = Executable-                        { exeName = testName test-                        , modulePath = f-                        , buildInfo  = bi-                        }-                    progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)-                    lbi'   = lbi {-                               withPrograms  = progs',-                               withPackageDB = withPackageDB lbi ++ [internalPackageDB]-                             }-                pre comp lbi'-                info verbosity $ "Building test suite " ++ testName test ++ "..."-                buildExe verbosity pkg_descr lbi' exe clbi-            TestSuiteLibV09 _ m -> do-                pwd <- getCurrentDirectory-                let bi  = testBuildInfo test-                    lib = Library-                        { exposedModules = [ m ]-                        , libExposed = True-                        , libBuildInfo = bi-                        }-                    pkg = pkg_descr-                        { package = (package pkg_descr)-                            { pkgName = PackageName $ testName test-                            }-                        , buildDepends = targetBuildDepends $ testBuildInfo test-                        , executables = []-                        , testSuites = []-                        , library = Just lib-                        }-                    ipi = (inplaceInstalledPackageInfo-                        pwd distPref pkg lib lbi clbi)-                        { IPI.installedPackageId = inplacePackageId $ packageId ipi-                        }-                    testDir = buildDir lbi' </> stubName test-                        </> stubName test ++ "-tmp"-                    testLibDep = thisPackageVersion $ package pkg-                    exe = Executable-                        { exeName = stubName test-                        , modulePath = stubFilePath test-                        , buildInfo = (testBuildInfo test)-                            { hsSourceDirs = [ testDir ]-                            , targetBuildDepends = testLibDep-                                : (targetBuildDepends $ testBuildInfo test)-                            }-                        }-                    -- | The stub executable needs a new 'ComponentLocalBuildInfo'-                    -- that exposes the relevant test suite library.-                    exeClbi = clbi-                        { componentPackageDeps =-                            (IPI.installedPackageId ipi, packageId ipi)-                            : (filter (\(_, x) -> let PackageName name = pkgName x in name == "Cabal" || name == "base")-                                $ componentPackageDeps clbi)-                        }-                    progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)-                    lbi'   = lbi {-                               withPrograms  = progs',-                               withPackageDB = withPackageDB lbi ++ [internalPackageDB]-                             }--                pre comp lbi'-                info verbosity $ "Building test suite " ++ testName test ++ "..."-                buildLib verbosity pkg lbi' lib clbi-                registerPackage verbosity ipi pkg lbi' True $ withPackageDB lbi'-                buildExe verbosity pkg_descr lbi' exe exeClbi-            TestSuiteUnsupported tt -> die $ "No support for building test suite "-                                          ++ "type " ++ display tt--      CBench bm -> do-        case benchmarkInterface bm of-            BenchmarkExeV10 _ f -> do-                let bi  = benchmarkBuildInfo bm-                    exe = Executable-                        { exeName = benchmarkName bm-                        , modulePath = f-                        , buildInfo  = bi-                        }-                    progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)-                    lbi'   = lbi {-                               withPrograms  = progs',-                               withPackageDB = withPackageDB lbi ++ [internalPackageDB]-                             }-                pre comp lbi'-                info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..."-                buildExe verbosity pkg_descr lbi' exe clbi-            BenchmarkUnsupported tt -> die $ "No support for building benchmark "-                                          ++ "type " ++ display tt---- | Initialize a new package db file for libraries defined--- internally to the package.-createInternalPackageDB :: FilePath -> IO PackageDB-createInternalPackageDB distPref = do-    let dbFile = distPref </> "package.conf.inplace"-        packageDB = SpecificPackageDB dbFile-    writeFile dbFile "[]"-    return packageDB--addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo-                      -> ProgramDb -> ProgramDb-addInternalBuildTools pkg lbi bi progs =-    foldr updateProgram progs internalBuildTools-  where-    internalBuildTools =-      [ simpleConfiguredProgram toolName (FoundOnSystem toolLocation)-      | toolName <- toolNames-      , let toolLocation = buildDir lbi </> toolName </> toolName <.> exeExtension ]-    toolNames = intersect buildToolNames internalExeNames-    internalExeNames = map exeName (executables pkg)-    buildToolNames   = map buildToolName (buildTools bi)-      where-        buildToolName (Dependency (PackageName name) _ ) = name----- TODO: build separate libs in separate dirs so that we can build--- multiple libs, e.g. for 'LibTest' library-style testsuites-buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity pkg_descr lbi lib clbi =-  case compilerFlavor (compiler lbi) of-    GHC  -> GHC.buildLib  verbosity pkg_descr lbi lib clbi-    JHC  -> JHC.buildLib  verbosity pkg_descr lbi lib clbi-    LHC  -> LHC.buildLib  verbosity pkg_descr lbi lib clbi-    Hugs -> Hugs.buildLib verbosity pkg_descr lbi lib clbi-    NHC  -> NHC.buildLib  verbosity pkg_descr lbi lib clbi-    UHC  -> UHC.buildLib  verbosity pkg_descr lbi lib clbi-    _    -> die "Building is not supported with this compiler."--buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity pkg_descr lbi exe clbi =-  case compilerFlavor (compiler lbi) of-    GHC  -> GHC.buildExe  verbosity pkg_descr lbi exe clbi-    JHC  -> JHC.buildExe  verbosity pkg_descr lbi exe clbi-    LHC  -> LHC.buildExe  verbosity pkg_descr lbi exe clbi-    Hugs -> Hugs.buildExe verbosity pkg_descr lbi exe clbi-    NHC  -> NHC.buildExe  verbosity pkg_descr lbi exe clbi-    UHC  -> UHC.buildExe  verbosity pkg_descr lbi exe clbi-    _    -> die "Building is not supported with this compiler."--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 = do-  -- check that there's something to build-  let buildInfos =-          map libBuildInfo (maybeToList (library pkg_descr)) ++-          map buildInfo (executables pkg_descr)-  unless (any buildable buildInfos) $ do-    let name = display (packageId pkg_descr)-    die ("Package " ++ name ++ " can't be built on this system.")--  createDirectoryIfMissingVerbose verbosity True (buildDir lbi)--  writeAutogenFiles verbosity pkg_descr lbi---- | Generate and write out the Paths_<pkg>.hs and cabal_macros.h files----writeAutogenFiles :: Verbosity-                  -> PackageDescription-                  -> LocalBuildInfo-                  -> IO ()-writeAutogenFiles verbosity pkg lbi = do-  createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi)--  let pathsModulePath = autogenModulesDir lbi-                    </> ModuleName.toFilePath (autogenModuleName pkg) <.> "hs"-  rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi)--  let cppHeaderPath = autogenModulesDir lbi </> cppHeaderName-  rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi)
− Distribution/Simple/Build/Macros.hs 
@@ -1,57 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Build.Macros--- Copyright   :  Simon Marlow 2008------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Generate cabal_macros.h - CPP macros for package version testing------ When using CPP you get------ > VERSION_<package>--- > MIN_VERSION_<package>(A,B,C)------ for each /package/ in @build-depends@, which is true if the version of--- /package/ in use is @>= A.B.C@, using the normal ordering on version--- numbers.----module Distribution.Simple.Build.Macros (-    generate-  ) where--import Distribution.Package-         ( PackageIdentifier(PackageIdentifier) )-import Distribution.Version-         ( Version(versionBranch) )-import Distribution.PackageDescription-         ( PackageDescription )-import Distribution.Simple.LocalBuildInfo-        ( LocalBuildInfo, externalPackageDeps )-import Distribution.Text-         ( display )---- --------------------------------------------------------------- * Generate cabal_macros.h--- --------------------------------------------------------------generate :: PackageDescription -> LocalBuildInfo -> String-generate _pkg_descr lbi = concat $-  "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" :-  [ concat-    ["/* package ",display pkgid," */\n"-    ,"#define VERSION_",pkgname," ",show (display version),"\n"-    ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n"-    ,"  (major1) <  ",major1," || \\\n"-    ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"-    ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"-    ,"\n\n"-    ]-  | (_, pkgid@(PackageIdentifier name version)) <- externalPackageDeps lbi-  , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)-        pkgname = map fixchar (display name)-  ]-  where fixchar '-' = '_'-        fixchar c   = c-
− Distribution/Simple/Build/PathsModule.hs 
@@ -1,258 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Build.Macros--- Copyright   :  Isaac Jones 2003-2005,---                Ross Paterson 2006,---                Duncan Coutts 2007-2008------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Generating the Paths_pkgname module.------ 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 (-    generate, pkgPathEnvVar-  ) where--import Distribution.System-         ( OS(Windows), buildOS )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), compilerFlavor, compilerVersion )-import Distribution.Package-         ( packageId, packageName, packageVersion )-import Distribution.PackageDescription-         ( PackageDescription(..), hasLibs )-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), InstallDirs(..)-         , absoluteInstallDirs, prefixRelativeInstallDirs )-import Distribution.Simple.Setup ( CopyDest(NoCopyDest) )-import Distribution.Simple.BuildPaths-         ( autogenModuleName )-import Distribution.Text-         ( display )-import Distribution.Version-         ( Version(..), orLaterVersion, withinRange )--import System.FilePath-         ( pathSeparator )-import Data.Maybe-         ( fromJust, isNothing )---- --------------------------------------------------------------- * Building Paths_<pkg>.hs--- --------------------------------------------------------------generate :: PackageDescription -> LocalBuildInfo -> String-generate pkg_descr lbi =-   let pragmas-        | absolute || isHugs = ""-        | supports_language_pragma =-          "{-# LANGUAGE ForeignFunctionInterface #-}\n"-        | otherwise =-          "{-# OPTIONS_GHC -fffi #-}\n"++-          "{-# OPTIONS_JHC -fffi #-}\n"--       foreign_imports-        | absolute = ""-        | isHugs = "import System.Environment\n"-        | otherwise =-          "import Foreign\n"++-          "import Foreign.C\n"--       header =-        pragmas++-        "module " ++ display paths_modulename ++ " (\n"++-        "    version,\n"++-        "    getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++-        "    getDataFileName\n"++-        "  ) where\n"++-        "\n"++-        foreign_imports++-        "import qualified Control.Exception as Exception\n"++-        "import Data.Version (Version(..))\n"++-        "import System.Environment (getEnv)"++-        "\n"++-        "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++-        "catchIO = Exception.catch\n" ++-        "\n"++-        "\nversion :: Version"++-        "\nversion = " ++ show (packageVersion pkg_descr)--       body-        | absolute =-          "\nbindir, libdir, datadir, libexecdir :: FilePath\n"++-          "\nbindir     = " ++ show flat_bindir ++-          "\nlibdir     = " ++ show flat_libdir ++-          "\ndatadir    = " ++ show flat_datadir ++-          "\nlibexecdir = " ++ show flat_libexecdir ++-          "\n"++-          "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"++-          "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++-          "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++-          "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++-          "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++-          "\n"++-          "getDataFileName :: FilePath -> IO FilePath\n"++-          "getDataFileName name = do\n"++-          "  dir <- getDataDir\n"++-          "  return (dir ++ "++path_sep++" ++ name)\n"-        | otherwise =-          "\nprefix, bindirrel :: FilePath" ++-          "\nprefix        = " ++ show flat_prefix ++-          "\nbindirrel     = " ++ show (fromJust flat_bindirrel) ++-          "\n\n"++-          "getBinDir :: IO FilePath\n"++-          "getBinDir = getPrefixDirRel bindirrel\n\n"++-          "getLibDir :: IO FilePath\n"++-          "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++-          "getDataDir :: IO FilePath\n"++-          "getDataDir =  "++ mkGetEnvOr "datadir"-                              (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++-          "getLibexecDir :: IO FilePath\n"++-          "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++-          "getDataFileName :: FilePath -> IO FilePath\n"++-          "getDataFileName name = do\n"++-          "  dir <- getDataDir\n"++-          "  return (dir `joinFileName` name)\n"++-          "\n"++-          get_prefix_stuff++-          "\n"++-          filename_stuff-   in header++body-- where-        InstallDirs {-          prefix     = flat_prefix,-          bindir     = flat_bindir,-          libdir     = flat_libdir,-          datadir    = flat_datadir,-          libexecdir = flat_libexecdir-        } = absoluteInstallDirs pkg_descr lbi NoCopyDest-        InstallDirs {-          bindir     = flat_bindirrel,-          libdir     = flat_libdirrel,-          datadir    = flat_datadirrel,-          libexecdir = flat_libexecdirrel,-          progdir    = flat_progdirrel-        } = prefixRelativeInstallDirs (packageId pkg_descr) lbi--        mkGetDir _   (Just dirrel) = "getPrefixDirRel " ++ show dirrel-        mkGetDir dir Nothing       = "return " ++ show dir--        mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++-                              " (\\_ -> "++expr++")"-          where var' = pkgPathEnvVar pkg_descr var--        -- 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-          || (isHugs && isNothing flat_progdirrel)-          || not (supportsRelocatableProgs (compilerFlavor (compiler lbi)))--        supportsRelocatableProgs Hugs = True-        supportsRelocatableProgs GHC  = case buildOS of-                           Windows   -> True-                           _         -> False-        supportsRelocatableProgs _    = False--        paths_modulename = autogenModuleName pkg_descr--        isHugs = compilerFlavor (compiler lbi) == Hugs-        get_prefix_stuff-          | isHugs    = "progdirrel :: String\n"++-                        "progdirrel = "++show (fromJust flat_progdirrel)++"\n\n"++-                        get_prefix_hugs-          | otherwise = get_prefix_win32--        path_sep = show [pathSeparator]--        supports_language_pragma =-          compilerFlavor (compiler lbi) == GHC &&-            (compilerVersion (compiler lbi)-              `withinRange` orLaterVersion (Version [6,6,1] []))---- | Generates the name of the environment variable controlling the path--- component of interest.-pkgPathEnvVar :: PackageDescription-              -> String     -- ^ path component; one of \"bindir\", \"libdir\",-                            -- \"datadir\" or \"libexecdir\"-              -> String     -- ^ environment variable name-pkgPathEnvVar pkg_descr var =-    showPkgName (packageName pkg_descr) ++ "_" ++ var-    where-        showPkgName = map fixchar . display-        fixchar '-' = '_'-        fixchar c   = c--get_prefix_win32 :: String-get_prefix_win32 =-  "getPrefixDirRel :: FilePath -> IO FilePath\n"++-  "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"++-  "  where\n"++-  "    try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n"++-  "        ret <- c_GetModuleFileName nullPtr buf size\n"++-  "        case ret of\n"++-  "          0 -> return (prefix `joinFileName` dirRel)\n"++-  "          _ | ret < size -> do\n"++-  "              exePath <- peekCWString buf\n"++-  "              let (bindir,_) = splitFileName exePath\n"++-  "              return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++-  "            | otherwise  -> try_size (size * 2)\n"++-  "\n"++-  "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n"++-  "  c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n"---get_prefix_hugs :: String-get_prefix_hugs =-  "getPrefixDirRel :: FilePath -> IO FilePath\n"++-  "getPrefixDirRel dirRel = do\n"++-  "  mainPath <- getProgName\n"++-  "  let (progPath,_) = splitFileName mainPath\n"++-  "  let (progdir,_) = splitFileName progPath\n"++-  "  return ((progdir `minusFileName` progdirrel) `joinFileName` dirRel)\n"--filename_stuff :: String-filename_stuff =-  "minusFileName :: FilePath -> String -> FilePath\n"++-  "minusFileName dir \"\"     = dir\n"++-  "minusFileName dir \".\"    = dir\n"++-  "minusFileName dir suffix =\n"++-  "  minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"++-  "\n"++-  "joinFileName :: String -> String -> FilePath\n"++-  "joinFileName \"\"  fname = fname\n"++-  "joinFileName \".\" fname = fname\n"++-  "joinFileName dir \"\"    = dir\n"++-  "joinFileName dir fname\n"++-  "  | isPathSeparator (last dir) = dir++fname\n"++-  "  | otherwise                  = dir++pathSeparator:fname\n"++-  "\n"++-  "splitFileName :: FilePath -> (String, String)\n"++-  "splitFileName p = (reverse (path2++drive), reverse fname)\n"++-  "  where\n"++-  "    (path,drive) = case p of\n"++-  "       (c:':':p') -> (reverse p',[':',c])\n"++-  "       _          -> (reverse p ,\"\")\n"++-  "    (fname,path1) = break isPathSeparator path\n"++-  "    path2 = case path1 of\n"++-  "      []                           -> \".\"\n"++-  "      [_]                          -> path1   -- don't remove the trailing slash if \n"++-  "                                              -- there is only one character\n"++-  "      (c:path') | isPathSeparator c -> path'\n"++-  "      _                             -> path1\n"++-  "\n"++-  "pathSeparator :: Char\n"++-  (case buildOS of-       Windows   -> "pathSeparator = '\\\\'\n"-       _         -> "pathSeparator = '/'\n") ++-  "\n"++-  "isPathSeparator :: Char -> Bool\n"++-  (case buildOS of-       Windows   -> "isPathSeparator c = c == '/' || c == '\\\\'\n"-       _         -> "isPathSeparator c = c == '/'\n")
− Distribution/Simple/BuildPaths.hs 
@@ -1,150 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.BuildPaths--- Copyright   :  Isaac Jones 2003-2004,---                Duncan Coutts 2008------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ A bunch of dirs, paths and file names used for intermediate build steps.-----{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.BuildPaths (-    defaultDistPref, srcPref,-    hscolourPref, haddockPref,-    autogenModulesDir,--    autogenModuleName,-    cppHeaderName,-    haddockName,--    mkLibName,-    mkProfLibName,-    mkSharedLibName,--    exeExtension,-    objExtension,-    dllExtension,--  ) where---import System.FilePath ((</>), (<.>))--import Distribution.Package-         ( PackageIdentifier, packageName )-import Distribution.ModuleName (ModuleName)-import qualified Distribution.ModuleName as ModuleName-import Distribution.Compiler-         ( CompilerId(..) )-import Distribution.PackageDescription (PackageDescription)-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir))-import Distribution.Simple.Setup (defaultDistPref)-import Distribution.Text-         ( display )-import Distribution.System (OS(..), buildOS)---- ------------------------------------------------------------------------------ Build directories and files--srcPref :: FilePath -> FilePath-srcPref distPref = distPref </> "src"--hscolourPref :: FilePath -> PackageDescription -> FilePath-hscolourPref = haddockPref--haddockPref :: FilePath -> PackageDescription -> FilePath-haddockPref distPref pkg_descr-    = distPref </> "doc" </> "html" </> display (packageName pkg_descr)---- |The directory in which we put auto-generated modules-autogenModulesDir :: LocalBuildInfo -> String-autogenModulesDir lbi = buildDir lbi </> "autogen"--cppHeaderName :: String-cppHeaderName = "cabal_macros.h"---- |The name of the auto-generated module associated with a package-autogenModuleName :: PackageDescription -> ModuleName-autogenModuleName pkg_descr =-  ModuleName.fromString $-    "Paths_" ++ map fixchar (display (packageName pkg_descr))-  where fixchar '-' = '_'-        fixchar c   = c--haddockName :: PackageDescription -> FilePath-haddockName pkg_descr = display (packageName pkg_descr) <.> "haddock"---- ------------------------------------------------------------------------------ Library file names--mkLibName :: PackageIdentifier -> String-mkLibName lib = "libHS" ++ display lib <.> "a"--mkProfLibName :: PackageIdentifier -> String-mkProfLibName lib =  "libHS" ++ display lib ++ "_p" <.> "a"---- Implement proper name mangling for dynamical shared objects--- libHS<packagename>-<compilerFlavour><compilerVersion>--- e.g. libHSbase-2.1-ghc6.6.1.so-mkSharedLibName :: PackageIdentifier -> CompilerId -> String-mkSharedLibName lib (CompilerId compilerFlavor compilerVersion)-  = "libHS" ++ display lib ++ "-" ++ comp <.> dllExtension-  where comp = display compilerFlavor ++ display compilerVersion---- --------------------------------------------------------------- * Platform file extensions--- ---------------------------------------------------------------- ToDo: This should be determined via autoconf (AC_EXEEXT)--- | Extension for executable files--- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)-exeExtension :: String-exeExtension = case buildOS of-                   Windows -> "exe"-                   _       -> ""---- ToDo: This should be determined via autoconf (AC_OBJEXT)--- | Extension for object files. For GHC and NHC the extension is @\"o\"@.--- Hugs uses either @\"o\"@ or @\"obj\"@ depending on the used C compiler.-objExtension :: String-objExtension = "o"---- | Extension for dynamically linked (or shared) libraries--- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows)-dllExtension :: String-dllExtension = case buildOS of-                   Windows -> "dll"-                   OSX     -> "dylib"-                   _       -> "so"
− Distribution/Simple/Command.hs 
@@ -1,545 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Command--- Copyright   :  Duncan Coutts 2007------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This is to do with command line handling. The Cabal command line is--- organised into a number of named sub-commands (much like darcs). The--- 'CommandUI' abstraction represents one of these sub-commands, with a name,--- description, a set of flags. Commands can be associated with actions and--- 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@.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.Command (--  -- * Command interface-  CommandUI(..),-  commandShowOptions,-  CommandParse(..),-  commandParseArgs,--  -- ** Constructing commands-  ShowOrParseArgs(..),-  makeCommand,--  -- ** Associating actions with commands-  Command,-  commandAddAction,-  noExtraFlags,--  -- ** Running commands-  commandsRun,---- * Option Fields-  OptionField(..), Name,---- ** Constructing Option Fields-  option, multiOption,---- ** Liftings & Projections-  liftOption, viewAsFieldDescr,---- * Option Descriptions-  OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder,---- ** OptDescr 'smart' constructors-  MkOptDescr,-  reqArg, reqArg', optArg, optArg', noArg,-  boolOpt, boolOpt', choiceOpt, choiceOptFromEnum--  ) where--import Control.Monad-import Data.Char (isAlpha, toLower)-import Data.List (sortBy)-import Data.Maybe-import Data.Monoid-import qualified Distribution.GetOpt as GetOpt-import Distribution.Text-         ( Text(disp, parse) )-import Distribution.ParseUtils-import Distribution.ReadE-import Distribution.Simple.Utils (die, intercalate)-import Text.PrettyPrint    ( punctuate, cat, comma, text, empty)--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,-    -- | The useage line summary for this command-    commandUsage    :: String -> String,-    -- | Additional explanation of the command to use in help texts.-    commandDescription :: Maybe (String -> String),-    -- | Initial \/ empty flags-    commandDefaultFlags :: flags,-    -- | All the Option fields for this command-    commandOptions     :: ShowOrParseArgs -> [OptionField flags]-  }--data ShowOrParseArgs = ShowArgs | ParseArgs--type Name        = String-type Description = String---- | We usually have a datatype for storing configuration values, where---   every field stores a configuration option, and the user sets---   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 datatype.-data OptionField a = OptionField {-  optionName        :: Name,-  optionDescr       :: [OptDescr a] }---- | An OptionField takes one or more OptDescrs, describing the command line interface for the field.-data OptDescr a  = ReqArg Description OptFlags ArgPlaceHolder (ReadE (a->a))         (a -> [String])-                 | OptArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a->a)  (a -> [Maybe String])-                 | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)]-                 | BoolOpt Description OptFlags{-True-} OptFlags{-False-} (Bool -> a -> a) (a-> Maybe Bool)---- | Short command line option strings-type SFlags   = [Char]--- | Long command line option strings-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"---- | 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 n get set args = OptionField n [arg get set | arg <- args]--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-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)---- | 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)---- | (String -> a) variant of "reqArg"-reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String])-                    -> MkOptDescr (a -> b) (b -> a -> a) a-reqArg' ad 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' ad mkflag showflag =-    optArg ad (succeedReadE (mkflag . Just)) def showflag-      where def = mkflag Nothing--noArg :: (Eq b, Monoid b) => b -> MkOptDescr (a -> b) (b -> a -> a) a-noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d--boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags -> MkOptDescr (a -> b) (b -> a -> a) a-boolOpt g s sfT sfF _sf _lf@(n:_) d get set =-    BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get)-boolOpt _ _ _ _ _ _ _ _ _ = error "Distribution.Simple.Setup.boolOpt: unreachable"--boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags -> MkOptDescr (a -> b) (b -> a -> a) a-boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get)---- | create a Choice option-choiceOpt :: Eq b => [(b,OptFlags,Description)] -> MkOptDescr (a -> b) (b -> a -> a) a-choiceOpt aa_ff _sf _lf _d get set  = ChoiceOpt alts-    where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff]---- | 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 _sf _lf d get = choiceOpt [ (x, (sf, [map toLower $ show x]), d')-                                                | (x, sf) <- sflags'-                                                , let d' = d ++ show x]-                                            _sf _lf d get-    where sflags' = foldl f [] [firstOne..]-          f prev x = let prevflags = concatMap snd prev in-                     prev ++ take 1 [(x, [toLower sf]) | sf <- show x, isAlpha sf-                                                       , toLower sf `notElem` prevflags]-          firstOne = minBound `asTypeOf` get undefined--commandGetOpts :: ShowOrParseArgs -> CommandUI flags -> [GetOpt.OptDescr (flags -> flags)]-commandGetOpts showOrParse command =-    concatMap viewAsGetOpt (commandOptions command showOrParse)--viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)]-viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa-  where-    optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) =-         [GetOpt.Option cs ss (GetOpt.ReqArg 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 (ChoiceOpt alts) =-         [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ]-    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) ]---- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > Choice > Opt) and consider only the first one.-viewAsFieldDescr :: OptionField a -> FieldDescr a-viewAsFieldDescr (OptionField _n []) = error "Distribution.command.viewAsFieldDescr: unexpected"-viewAsFieldDescr (OptionField n dd) = FieldDescr n get set-    where optDescr = head $ sortBy cmp dd-          ReqArg{}    `cmp` ReqArg{}    = EQ-          ReqArg{}    `cmp` _           = GT-          BoolOpt{}   `cmp` ReqArg{}    = LT-          BoolOpt{}   `cmp` BoolOpt{}   = EQ-          BoolOpt{}   `cmp` _           = GT-          ChoiceOpt{} `cmp` ReqArg{}    = LT-          ChoiceOpt{} `cmp` BoolOpt{}   = LT-          ChoiceOpt{} `cmp` ChoiceOpt{} = EQ-          ChoiceOpt{} `cmp` _           = GT-          OptArg{}    `cmp` OptArg{}    = EQ-          OptArg{}    `cmp` _           = LT-          get t = case optDescr of-                    ReqArg _ _ _ _ ppr ->-                     (cat . punctuate comma . map text . ppr) t-                    OptArg _ _ _ _ _ ppr ->-                     case ppr t of-                        []        -> empty-                        (Nothing : _) -> text "True"-                        (Just a  : _) -> text a-                    ChoiceOpt alts ->-                     fromMaybe empty $ listToMaybe-                         [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]-                    BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t-          set line val a =-                  case optDescr of-                    ReqArg _ _ _ readE _    -> ($ a) `liftM` runE line n readE val-                                             -- We parse for a single value instead of a list,-                                             -- as one can't really implement parseList :: ReadE a -> ReadE [a]-                                             -- with the current ReadE definition-                    ChoiceOpt{}             -> case getChoiceByLongFlag optDescr val of-                                                 Just f -> return (f a)-                                                 _      -> syntaxError line val-                    BoolOpt _ _ _ setV _    -> (`setV` a) `liftM` runP line n parse val-                    OptArg _ _ _ _readE _ _ -> -- The behaviour in this case is not clear, and it has no use so far,-                                               -- so we avoid future surprises by not implementing it.-                                               error "Command.optionToFieldDescr: feature not implemented"--getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b)-getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe [ set | (_,(_sf,lf:_), set, _) <- alts-                                                             , lf == val]--getChoiceByLongFlag _ _ = error "Distribution.command.getChoiceByLongFlag: expected a choice option"--getCurrentChoice :: OptDescr a -> a -> [String]-getCurrentChoice (ChoiceOpt alts) 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}---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')--liftOptDescr get' set' (ReqArg d ff ad set 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')--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]-  where-    showOptDescr :: a -> OptDescr a -> [String]-    showOptDescr x (BoolOpt _ (_,lfT:_) (_,lfF:_) _ enabled)-      = case enabled x of-          Nothing -> []-          Just True  -> ["--" ++ lfT]-          Just False -> ["--" ++ lfF]-    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-      commandGetOpts ShowArgs command-  where-    listOption (GetOpt.Option shortNames 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 =-    commandUsage command pname- ++ (GetOpt.usageInfo ""-  . addCommonFlags ShowArgs-  $ commandGetOpts ShowArgs command)- ++ case commandDescription command of-      Nothing   -> ""-      Just desc -> '\n': desc pname---- | Make a Command from standard 'GetOpt' options.-makeCommand :: String                         -- ^ name-            -> String                         -- ^ short description-            -> Maybe (String -> String)       -- ^ long description-            -> flags                          -- ^ initial\/empty flags-            -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options-            -> CommandUI flags-makeCommand name shortDesc longDesc defaultFlags options =-  CommandUI {-    commandName         = name,-    commandSynopsis     = shortDesc,-    commandDescription  = longDesc,-    commandUsage        = usage,-    commandDefaultFlags = defaultFlags,-    commandOptions      = options-  }-  where usage pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"-                   ++ "Flags for " ++ name ++ ":"---- | Common flags that apply to every command-data CommonFlag = HelpFlag | ListOptionsFlag--commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag]-commonFlags showOrParseArgs = case showOrParseArgs of-  ShowArgs  -> [help]-  ParseArgs -> [help, list]- where-    help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag)-             "Show this help text"-    helpShortFlags = case showOrParseArgs of-      ShowArgs  -> ['h']-      ParseArgs -> ['h', '?']-    list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag)-             "Print a list of command line flags"--addCommonFlags :: ShowOrParseArgs-               -> [GetOpt.OptDescr a]-               -> [GetOpt.OptDescr (Either CommonFlag a)]-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---- | Parse a bunch of command line arguments----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 compsition is right to left.-        accum flags = foldr (flip (.)) id [ f | Right f <- flags ]-        unrecognised opts = [ "unrecognized option `" ++ opt ++ "'\n"-                            | opt <- opts ]-        -- For unrecognised global flags we put them in the position just after-        -- the command, if there is one. This gives us a chance to parse them-        -- as sub-command rather than global flags.-        mix []     ys = ys-        mix (x:xs) ys = x:ys++xs--data CommandParse flags = CommandHelp (String -> String)-                        | CommandList [String]-                        | CommandErrors [String]-                        | CommandReadyToGo flags-instance Functor CommandParse where-  fmap _ (CommandHelp help)       = CommandHelp help-  fmap _ (CommandList opts)       = CommandList opts-  fmap _ (CommandErrors errs)     = CommandErrors errs-  fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags)---data Command action = Command String String ([String] -> CommandParse action)--commandAddAction :: CommandUI flags-                 -> (flags -> [String] -> action)-                 -> Command action-commandAddAction command action =-  Command (commandName command)-          (commandSynopsis command)-          (fmap (uncurry applyDefaultArgs)-         . commandParseArgs command False)--  where applyDefaultArgs mkflags args =-          let flags = mkflags (commandDefaultFlags command)-           in action flags args--commandsRun :: CommandUI a-            -> [Command action]-            -> [String]-            -> CommandParse (a, CommandParse action)-commandsRun globalCommand commands args =-  case commandParseArgs globalCommand' True args of-    CommandHelp      help          -> CommandHelp help-    CommandList      opts          -> CommandList (opts ++ commandNames)-    CommandErrors    errs          -> CommandErrors errs-    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)-- where-    lookupCommand cname = [ cmd | cmd@(Command cname' _ _) <- commands'-                          , cname'==cname ]-    noCommand        = CommandErrors ["no command given (try --help)\n"]-    badCommand cname = CommandErrors ["unrecognised command: " ++ cname-                                   ++ " (try --help)\n"]-    commands'      = commands ++ [commandAddAction helpCommandUI undefined]-    commandNames   = [ name | Command name _ _ <- commands' ]-    globalCommand' = globalCommand {-      commandUsage = \pname ->-           (case commandUsage globalCommand pname of-             ""       -> ""-             original -> original ++ "\n")-        ++ "Usage: " ++ pname ++ " COMMAND [FLAGS]\n"-        ++ "   or: " ++ pname ++ " [GLOBAL FLAGS]\n\n"-        ++ "Global flags:",-      commandDescription = Just $ \pname ->-           "Commands:\n"-        ++ unlines [ "  " ++ align name ++ "    " ++ description-                   | Command name description _ <- commands' ]-        ++ case commandDescription globalCommand of-             Nothing   -> ""-             Just desc -> '\n': desc pname-    }-      where maxlen = maximum [ length name | Command name _ _ <- commands' ]-            align str = str ++ replicate (maxlen - length str) ' '--    -- A bit of a hack: support "prog help" as a synonym of "prog --help"-    -- furthermore, support "prog help command" as "prog command --help"-    handleHelpCommand cmdArgs =-      case commandParseArgs helpCommandUI True cmdArgs of-        CommandHelp      help    -> CommandHelp help-        CommandList      list    -> CommandList (list ++ commandNames)-        CommandErrors    _       -> CommandHelp globalHelp-        CommandReadyToGo (_,[])  -> CommandHelp globalHelp-        CommandReadyToGo (_,(name:cmdArgs')) ->-          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'-    helpCommandUI =-      (makeCommand "help" "Help about commands" Nothing () (const [])) {-        commandUsage = \pname ->-             "Usage: " ++ pname ++ " help [FLAGS]\n"-          ++ "   or: " ++ pname ++ " help COMMAND [FLAGS]\n\n"-          ++ "Flags for help:"-      }---- | 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 =-  die $ "Unrecognised flags: " ++ intercalate ", " extraFlags---TODO: eliminate this function and turn it into a variant on commandAddAction---      instead like commandAddActionNoArgs that doesn't supply the [String]
− Distribution/Simple/Compiler.hs 
@@ -1,194 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Compiler--- Copyright   :  Isaac Jones 2003-2004------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This should be a much more sophisticated abstraction than it is. Currently--- it's just a bit of data about the compiler, like it's flavour and name and--- version. The reason it's just data is because currently it has to be in--- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The--- only interesting bit of info it contains is a mapping between language--- extensions and compiler command line flags. This module also defines a--- 'PackageDB' type which is used to refer to package databases. Most compilers--- 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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.Compiler (-        -- * Haskell implementations-        module Distribution.Compiler,-        Compiler(..),-        showCompilerId, compilerFlavor, compilerVersion,--        -- * Support for package databases-        PackageDB(..),-        PackageDBStack,-        registrationPackageDB,--        -- * Support for optimisation levels-        OptimisationLevel(..),-        flagToOptimisationLevel,--        -- * Support for language extensions-        Flag,-        languageToFlags,-        unsupportedLanguages,-        extensionsToFlags,-        unsupportedExtensions-  ) where--import Distribution.Compiler-import Distribution.Version (Version(..))-import Distribution.Text (display)-import Language.Haskell.Extension (Language(Haskell98), Extension)--import Data.List (nub)-import Data.Maybe (catMaybes, isNothing)--data Compiler = Compiler {-        compilerId              :: CompilerId,-        compilerLanguages       :: [(Language, Flag)],-        compilerExtensions      :: [(Extension, Flag)]-    }-    deriving (Show, Read)--showCompilerId :: Compiler -> String-showCompilerId = display . compilerId--compilerFlavor ::  Compiler -> CompilerFlavor-compilerFlavor = (\(CompilerId f _) -> f) . compilerId--compilerVersion :: Compiler -> Version-compilerVersion = (\(CompilerId _ v) -> v) . compilerId---- --------------------------------------------------------------- * 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.----data PackageDB = GlobalPackageDB-               | UserPackageDB-               | SpecificPackageDB FilePath-    deriving (Eq, Ord, Show, Read)---- | We typically get packages from several databases, and stack them--- together. This type lets us be explicit about that stacking. For example--- typical stacks include:------ > [GlobalPackageDB]--- > [GlobalPackageDB, UserPackageDB]--- > [GlobalPackageDB, SpecificPackageDB "package.conf.inplace"]------ Note that the 'GlobalPackageDB' is invariably at the bottom since it--- contains the rts, base and other special compiler-specific packages.------ We are not restricted to using just the above combinations. In particular--- we can use several custom package dbs and the user package db together.------ When it comes to writing, the top most (last) package is used.----type PackageDBStack = [PackageDB]---- | Return the package that we should register into. This is the package db at--- the top of the stack.----registrationPackageDB :: PackageDBStack -> PackageDB-registrationPackageDB []  = error "internal error: empty package db set"-registrationPackageDB dbs = last dbs---- --------------------------------------------------------------- * Optimisation levels--- ---------------------------------------------------------------- | Some compilers support optimising. Some have different levels.--- For compliers that do not the level is just capped to the level--- they do support.----data OptimisationLevel = NoOptimisation-                       | NormalOptimisation-                       | MaximumOptimisation-    deriving (Eq, Show, Read, Enum, Bounded)--flagToOptimisationLevel :: Maybe String -> OptimisationLevel-flagToOptimisationLevel Nothing  = NormalOptimisation-flagToOptimisationLevel (Just s) = case reads s of-  [(i, "")]-    | i >= fromEnum (minBound :: OptimisationLevel)-   && i <= fromEnum (maxBound :: OptimisationLevel)-                -> toEnum i-    | otherwise -> error $ "Bad optimisation level: " ++ show i-                        ++ ". Valid values are 0..2"-  _             -> error $ "Can't parse optimisation level " ++ s---- --------------------------------------------------------------- * Languages and Extensions--- --------------------------------------------------------------unsupportedLanguages :: Compiler -> [Language] -> [Language]-unsupportedLanguages comp langs =-  [ lang | lang <- langs-         , isNothing (languageToFlag comp lang) ]--languageToFlags :: Compiler -> Maybe Language -> [Flag]-languageToFlags comp = filter (not . null)-                     . catMaybes . map (languageToFlag comp)-                     . maybe [Haskell98] (\x->[x])--languageToFlag :: Compiler -> Language -> Maybe Flag-languageToFlag comp ext = lookup ext (compilerLanguages comp)----- |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) ]--type Flag = String---- |For the given compiler, return the flags for the supported extensions.-extensionsToFlags :: Compiler -> [Extension] -> [Flag]-extensionsToFlags comp = nub . filter (not . null)-                       . catMaybes . map (extensionToFlag comp)--extensionToFlag :: Compiler -> Extension -> Maybe Flag-extensionToFlag comp ext = lookup ext (compilerExtensions comp)
− Distribution/Simple/Configure.hs 
@@ -1,1042 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Configure--- Copyright   :  Isaac Jones 2003-2005------ 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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.Configure (configure,-                                      writePersistBuildConfig,-                                      getPersistBuildConfig,-                                      checkPersistBuildConfigOutdated,-                                      maybeGetPersistBuildConfig,-                                      localBuildInfoFile,-                                      getInstalledPackages,-                                      configCompiler, configCompilerAux,-                                      ccLdOptionsBuildInfo,-                                      tryGetConfigStateFile,-                                      checkForeignDeps,-                                     )-    where--import Distribution.Simple.Compiler-    ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion-    , showCompilerId, unsupportedLanguages, unsupportedExtensions-    , PackageDB(..), PackageDBStack )-import Distribution.Package-    ( PackageName(PackageName), PackageIdentifier(..), PackageId-    , packageName, packageVersion, Package(..)-    , Dependency(Dependency), simplifyDependency-    , InstalledPackageId(..) )-import Distribution.InstalledPackageInfo as Installed-    ( InstalledPackageInfo, InstalledPackageInfo_(..)-    , emptyInstalledPackageInfo )-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)-import Distribution.PackageDescription as PD-    ( PackageDescription(..), specVersion, GenericPackageDescription(..)-    , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions-    , HookedBuildInfo, updatePackageDescription, allBuildInfo-    , FlagName(..), TestSuite(..), Benchmark(..) )-import Distribution.PackageDescription.Configuration-    ( finalizePackageDescription, mapTreeData )-import Distribution.PackageDescription.Check-    ( PackageCheck(..), checkPackage, checkPackageFiles )-import Distribution.Simple.Hpc ( enableCoverage )-import Distribution.Simple.Program-    ( Program(..), ProgramLocation(..), ConfiguredProgram(..)-    , ProgramConfiguration, defaultProgramConfiguration-    , configureAllKnownPrograms, knownPrograms, lookupKnownProgram-    , userSpecifyArgss, userSpecifyPaths-    , requireProgram, requireProgramVersion-    , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf )-import Distribution.Simple.Setup-    ( ConfigFlags(..), CopyDest(..), fromFlag, fromFlagOrDefault, flagToMaybe )-import Distribution.Simple.InstallDirs-    ( InstallDirs(..), defaultInstallDirs, combineInstallDirs )-import Distribution.Simple.LocalBuildInfo-    ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-    , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId-    , allComponentsBy, Component(..), foldComponent, ComponentName(..) )-import Distribution.Simple.BuildPaths-    ( autogenModulesDir )-import Distribution.Simple.Utils-    ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose-    , intercalate, cabalVersion-    , withFileContents, writeFileAtomic-    , withTempFile )-import Distribution.System-    ( OS(..), buildOS, buildPlatform )-import Distribution.Version-         ( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion )-import Distribution.Verbosity-    ( Verbosity, lessVerbose )--import qualified Distribution.Simple.GHC  as GHC-import qualified Distribution.Simple.JHC  as JHC-import qualified Distribution.Simple.LHC  as LHC-import qualified Distribution.Simple.NHC  as NHC-import qualified Distribution.Simple.Hugs as Hugs-import qualified Distribution.Simple.UHC  as UHC--import Control.Monad-    ( when, unless, foldM, filterM, forM )-import Data.List-    ( nub, partition, isPrefixOf, inits, find )-import Data.Maybe-    ( isNothing, catMaybes, mapMaybe )-import Data.Monoid-    ( Monoid(..) )-import Data.Graph-    ( SCC(..), graphFromEdges, transposeG, vertices, stronglyConnCompR )-import System.Directory-    ( doesFileExist, getModificationTime, createDirectoryIfMissing, getTemporaryDirectory )-import System.Exit-    ( ExitCode(..), exitWith )-import System.FilePath-    ( (</>), isAbsolute )-import qualified System.Info-    ( compilerName, compilerVersion )-import System.IO-    ( hPutStrLn, stderr, hClose )-import Distribution.Text-    ( Text(disp), display, simpleParse )-import Text.PrettyPrint-    ( comma, punctuate, render, nest, sep )-import Distribution.Compat.Exception ( catchExit, catchIO )--import Prelude hiding (catch)--tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a)-tryGetConfigStateFile filename = do-  exists <- doesFileExist filename-  if not exists-    then return (Left missing)-    else withFileContents filename $ \str ->-      case lines str of-        [headder, rest] -> case checkHeader headder of-          Just msg -> return (Left msg)-          Nothing  -> case reads rest of-            [(bi,_)] -> return (Right bi)-            _        -> return (Left cantParse)-        _            -> return (Left cantParse)-  where-    checkHeader :: String -> Maybe String-    checkHeader header = case parseHeader header of-      Just (cabalId, compId)-        | cabalId-       == currentCabalId -> Nothing-        | otherwise      -> Just (badVersion cabalId compId)-      Nothing            -> Just cantParse--    missing   = "Run the 'configure' command first."-    cantParse = "Saved package config file seems to be corrupt. "-             ++ "Try re-running the 'configure' command."-    badVersion cabalId compId-              = "You need to re-run the 'configure' command. "-             ++ "The version of Cabal being used has changed (was "-             ++ display cabalId ++ ", now "-             ++ display currentCabalId ++ ")."-             ++ badcompiler compId-    badcompiler compId | compId == currentCompilerId = ""-                       | otherwise-              = " Additionally the compiler is different (was "-             ++ display compId ++ ", now "-             ++ display currentCompilerId-             ++ ") which is probably the cause of the problem."---- internal function-tryGetPersistBuildConfig :: FilePath -> IO (Either String LocalBuildInfo)-tryGetPersistBuildConfig distPref-    = tryGetConfigStateFile (localBuildInfoFile distPref)---- |Read the 'localBuildInfoFile'.  Error if it doesn't exist.  Also--- fail if the file containing LocalBuildInfo is older than the .cabal--- file, indicating that a re-configure is required.-getPersistBuildConfig :: FilePath -> IO LocalBuildInfo-getPersistBuildConfig distPref = do-  lbi <- tryGetPersistBuildConfig distPref-  either die return lbi---- |Try to read the 'localBuildInfoFile'.-maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo)-maybeGetPersistBuildConfig distPref = do-  lbi <- tryGetPersistBuildConfig distPref-  return $ either (const Nothing) Just lbi---- |After running configure, output the 'LocalBuildInfo' to the--- 'localBuildInfoFile'.-writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO ()-writePersistBuildConfig distPref lbi = do-  createDirectoryIfMissing False distPref-  writeFileAtomic (localBuildInfoFile distPref)-                  (showHeader pkgid ++ '\n' : show lbi)-  where-    pkgid   = packageId (localPkgDescr lbi)--showHeader :: PackageIdentifier -> String-showHeader pkgid =-     "Saved package config for " ++ display pkgid-  ++ " written by " ++ display currentCabalId-  ++      " using " ++ display currentCompilerId-  where--currentCabalId :: PackageIdentifier-currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion--currentCompilerId :: PackageIdentifier-currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName)-                                      System.Info.compilerVersion--parseHeader :: String -> Maybe (PackageIdentifier, PackageIdentifier)-parseHeader header = case words header of-  ["Saved", "package", "config", "for", pkgid,-   "written", "by", cabalid, "using", compilerid]-    -> case (simpleParse pkgid :: Maybe PackageIdentifier,-             simpleParse cabalid,-             simpleParse compilerid) of-        (Just _,-         Just cabalid',-         Just compilerid') -> Just (cabalid', compilerid')-        _                  -> Nothing-  _                        -> Nothing---- |Check that localBuildInfoFile is up-to-date with respect to the--- .cabal file.-checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool-checkPersistBuildConfigOutdated distPref pkg_descr_file = do-  t0 <- getModificationTime pkg_descr_file-  t1 <- getModificationTime $ localBuildInfoFile distPref-  return (t0 > t1)---- |@dist\/setup-config@-localBuildInfoFile :: FilePath -> FilePath-localBuildInfoFile distPref = distPref </> "setup-config"---- -------------------------------------------------------------------------------- * Configuration--- --------------------------------------------------------------------------------- |Perform the \"@.\/setup configure@\" action.--- Returns the @.setup-config@ file.-configure :: (GenericPackageDescription, HookedBuildInfo)-          -> ConfigFlags -> IO LocalBuildInfo-configure (pkg_descr0, pbi) cfg-  = do  let distPref = fromFlag (configDistPref cfg)-            buildDir' = distPref </> "build"-            verbosity = fromFlag (configVerbosity cfg)--        setupMessage verbosity "Configuring" (packageId pkg_descr0)--        createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref--        let programsConfig = userSpecifyArgss (configProgramArgs cfg)-                           . userSpecifyPaths (configProgramPaths cfg)-                           $ configPrograms cfg-            userInstall = fromFlag (configUserInstall cfg)-            packageDbs = implicitPackageDbStack userInstall-                           (flagToMaybe $ configPackageDB cfg)--        -- detect compiler-        (comp, programsConfig') <- configCompiler-          (flagToMaybe $ configHcFlavor cfg)-          (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg)-          programsConfig (lessVerbose verbosity)-        let version = compilerVersion comp-            flavor  = compilerFlavor comp--        -- 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.  finalizePackageDescription-        -- does the resolution of conditionals, and it takes internalPackageSet-        -- as part of its input.-        ---        -- Currently a package can define no more than one library (which has-        -- the same name as the package) but we could extend this later.-        -- If we later allowed private internal libraries, then here we would-        -- need to pre-scan the conditional data to make a list of all private-        -- libraries that could possibly be defined by the .cabal file.-        let pid = packageId pkg_descr0-            internalPackage = emptyInstalledPackageInfo {-                --TODO: should use a per-compiler method to map the source-                --      package ID into an installed package id we can use-                --      for the internal package set. The open-codes use of-                --      InstalledPackageId . display here is a hack.-                Installed.installedPackageId = InstalledPackageId $ display $ pid,-                Installed.sourcePackageId = pid-              }-            internalPackageSet = PackageIndex.fromList [internalPackage]-        installedPackageSet <- getInstalledPackages (lessVerbose verbosity) comp-                                      packageDbs programsConfig'--        let -- Constraint test function for the solver-            dependencySatisfiable =-                not . null . PackageIndex.lookupDependency pkgs'-              where-                pkgs' = PackageIndex.insert internalPackage installedPackageSet-            enableTest t = t { testEnabled = fromFlag (configTests cfg) }-            flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t))-                               (condTestSuites pkg_descr0)-            enableBenchmark bm = bm { benchmarkEnabled = fromFlag (configBenchmarks cfg) }-            flaggedBenchmarks = map (\(n, bm) -> (n, mapTreeData enableBenchmark bm))-                               (condBenchmarks pkg_descr0)-            pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests-                                      , condBenchmarks = flaggedBenchmarks }--        (pkg_descr0', flags) <--                case finalizePackageDescription-                       (configConfigurationsFlags cfg)-                       dependencySatisfiable-                       Distribution.System.buildPlatform-                       (compilerId comp)-                       (configConstraints cfg)-                       pkg_descr0''-                of Right r -> return r-                   Left missing ->-                       die $ "At least the following dependencies are missing:\n"-                         ++ (render . nest 4 . sep . punctuate comma-                                    . map (disp . simplifyDependency)-                                    $ missing)--        -- add extra include/lib dirs as specified in cfg-        -- we do it here so that those get checked too-        let pkg_descr =-                enableCoverage (fromFlag (configLibCoverage cfg)) distPref-                $ addExtraIncludeLibDirs pkg_descr0'--        when (not (null flags)) $-          info verbosity $ "Flags chosen: "-                        ++ intercalate ", " [ name ++ "=" ++ display value-                                            | (FlagName name, value) <- flags ]--        checkPackageProblems verbosity pkg_descr0-          (updatePackageDescription pbi pkg_descr)--        let selectDependencies =-                (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ]))-              . map (selectDependency internalPackageSet installedPackageSet)--            (failedDeps, allPkgDeps) = selectDependencies (buildDepends pkg_descr)--            internalPkgDeps = [ pkgid | InternalDependency _ pkgid <- allPkgDeps ]-            externalPkgDeps = [ pkg   | ExternalDependency _ pkg   <- allPkgDeps ]--        when (not (null internalPkgDeps) && not (newPackageDepsBehaviour pkg_descr)) $-            die $ "The field 'build-depends: "-               ++ intercalate ", " (map (display . 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 failedDeps-        reportSelectedDependencies verbosity allPkgDeps--        packageDependsIndex <--          case PackageIndex.dependencyClosure installedPackageSet-                  (map Installed.installedPackageId externalPkgDeps) of-            Left packageDependsIndex -> return packageDependsIndex-            Right broken ->-              die $ "The following installed packages are broken because other"-                 ++ " packages they depend on are missing. These broken "-                 ++ "packages must be rebuilt before they can be used.\n"-                 ++ unlines [ "package "-                           ++ display (packageId pkg)-                           ++ " is broken due to missing package "-                           ++ intercalate ", " (map display deps)-                            | (pkg, deps) <- broken ]--        let pseudoTopPkg = emptyInstalledPackageInfo {-                Installed.installedPackageId = InstalledPackageId (display (packageId pkg_descr)),-                Installed.sourcePackageId = packageId pkg_descr,-                Installed.depends = map Installed.installedPackageId externalPkgDeps-              }-        case PackageIndex.dependencyInconsistencies-           . PackageIndex.insert pseudoTopPkg-           $ packageDependsIndex of-          [] -> return ()-          inconsistencies ->-            warn verbosity $-                 "This package indirectly depends on multiple versions of the same "-              ++ "package. This is highly likely to cause a compile failure.\n"-              ++ unlines [ "package " ++ display pkg ++ " requires "-                        ++ display (PackageIdentifier name ver)-                         | (name, uses) <- inconsistencies-                         , (pkg, ver) <- uses ]--        -- installation directories-        defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr)-        let installDirs = combineInstallDirs fromFlagOrDefault-                            defaultDirs (configInstallDirs cfg)--        -- check languages and extensions-        let langlist = nub $ catMaybes $ map defaultLanguage (allBuildInfo pkg_descr)-        let langs = unsupportedLanguages comp langlist-        when (not (null langs)) $-          die $ "The package " ++ display (packageId pkg_descr0)-             ++ " requires the following languages which are not "-             ++ "supported by " ++ display (compilerId comp) ++ ": "-             ++ intercalate ", " (map display langs)-        let extlist = nub $ concatMap allExtensions (allBuildInfo pkg_descr)-        let exts = unsupportedExtensions comp extlist-        when (not (null exts)) $-          die $ "The package " ++ display (packageId pkg_descr0)-             ++ " requires the following language extensions which are not "-             ++ "supported by " ++ display (compilerId comp) ++ ": "-             ++ intercalate ", " (map display exts)--        -- configured known/required programs & external build tools-        -- exclude build-tool deps on "internal" exes in the same package-        let requiredBuildTools =-              [ buildTool-              | let exeNames = map exeName (executables pkg_descr)-              , bi <- allBuildInfo pkg_descr-              , buildTool@(Dependency (PackageName toolName) reqVer) <- buildTools bi-              , let isInternal =-                        toolName `elem` exeNames-                        -- we assume all internal build-tools are-                        -- versioned with the package:-                     && packageVersion pkg_descr `withinRange` reqVer-              , not isInternal ]--        programsConfig'' <--              configureAllKnownPrograms (lessVerbose verbosity) programsConfig'-          >>= configureRequiredPrograms verbosity requiredBuildTools--        (pkg_descr', programsConfig''') <--          configurePkgconfigPackages verbosity pkg_descr programsConfig''--        split_objs <--           if not (fromFlag $ configSplitObjs cfg)-                then return False-                else case flavor of-                            GHC | version >= Version [6,5] [] -> return True-                            _ -> do warn verbosity-                                         ("this compiler does not support " ++-                                          "--enable-split-objs; ignoring")-                                    return False--        -- The allPkgDeps contains all the package deps for the whole package-        -- but we need to select the subset for this specific component.-        -- we just take the subset for the package names this component-        -- needs. Note, this only works because we cannot yet depend on two-        -- versions of the same package.-        let configLib lib = configComponent (libBuildInfo lib)-            configExe exe = (exeName exe, configComponent (buildInfo exe))-            configTest test = (testName test,-                    configComponent(testBuildInfo test))-            configBenchmark bm = (benchmarkName bm,-                    configComponent(benchmarkBuildInfo bm))-            configComponent bi = ComponentLocalBuildInfo {-              componentPackageDeps =-                if newPackageDepsBehaviour pkg_descr'-                  then [ (installedPackageId pkg, packageId pkg)-                       | pkg <- selectSubset bi externalPkgDeps ]-                    ++ [ (inplacePackageId pkgid, pkgid)-                       | pkgid <- selectSubset bi internalPkgDeps ]-                  else [ (installedPackageId pkg, packageId pkg)-                       | pkg <- externalPkgDeps ]-            }-            selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg]-            selectSubset bi pkgs =-                [ pkg | pkg <- pkgs, packageName pkg `elem` names ]-              where-                names = [ name | Dependency name _ <- targetBuildDepends bi ]--        -- Obtains the intrapackage dependencies for the given component-        let ipDeps component =-                 mapMaybe exeDepToComp (buildTools bi)-              ++ mapMaybe libDepToComp (targetBuildDepends bi)-              where-                bi = foldComponent libBuildInfo buildInfo testBuildInfo-                     benchmarkBuildInfo component-                exeDepToComp (Dependency (PackageName name) _) =-                  CExe `fmap` find ((==) name . exeName)-                                (executables pkg_descr')-                libDepToComp (Dependency pn _)-                  | pn `elem` map packageName internalPkgDeps =-                    CLib `fmap` library pkg_descr'-                libDepToComp _ = Nothing--        let sccs = (stronglyConnCompR . map lkup . vertices . transposeG) g-              where (g, lkup, _) = graphFromEdges-                                 $ allComponentsBy pkg_descr'-                                 $ \c -> (c, key c, map key (ipDeps c))-                    key          = foldComponent (const "library") exeName-                                   testName benchmarkName--        -- check for cycles in the dependency graph-        buildOrder <- forM sccs $ \scc -> case scc of-          AcyclicSCC (c,_,_) -> return (foldComponent (const CLibName)-                                                      (CExeName . exeName)-                                                      (CTestName . testName)-                                                      (CBenchName . benchmarkName)-                                                      c)-          CyclicSCC vs ->-            die $ "Found cycle in intrapackage dependency graph:\n  "-                ++ intercalate " depends on "-                     (map (\(_,k,_) -> "'" ++ k ++ "'") (vs ++ [head vs]))--        let lbi = LocalBuildInfo {-                    configFlags         = cfg,-                    extraConfigArgs     = [],  -- Currently configure does not-                                               -- take extra args, but if it-                                               -- did they would go here.-                    installDirTemplates = installDirs,-                    compiler            = comp,-                    buildDir            = buildDir',-                    scratchDir          = fromFlagOrDefault-                                            (distPref </> "scratch")-                                            (configScratchDir cfg),-                    libraryConfig       = configLib `fmap` library pkg_descr',-                    executableConfigs   = configExe `fmap` executables pkg_descr',-                    testSuiteConfigs    = configTest `fmap` testSuites pkg_descr',-                    benchmarkConfigs    = configBenchmark `fmap` benchmarks pkg_descr',-                    compBuildOrder      = buildOrder,-                    installedPkgs       = packageDependsIndex,-                    pkgDescrFile        = Nothing,-                    localPkgDescr       = pkg_descr',-                    withPrograms        = programsConfig''',-                    withVanillaLib      = fromFlag $ configVanillaLib cfg,-                    withProfLib         = fromFlag $ configProfLib cfg,-                    withSharedLib       = fromFlag $ configSharedLib cfg,-                    withDynExe          = fromFlag $ configDynExe cfg,-                    withProfExe         = fromFlag $ configProfExe cfg,-                    withOptimization    = fromFlag $ configOptimization cfg,-                    withGHCiLib         = fromFlag $ configGHCiLib cfg,-                    splitObjs           = split_objs,-                    stripExes           = fromFlag $ configStripExes cfg,-                    withPackageDB       = packageDbs,-                    progPrefix          = fromFlag $ configProgPrefix cfg,-                    progSuffix          = fromFlag $ configProgSuffix cfg-                  }--        let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest-            relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi--        unless (isAbsolute (prefix dirs)) $ die $-            "expected an absolute directory name for --prefix: " ++ prefix dirs--        info verbosity $ "Using " ++ display currentCabalId-                      ++ " compiled by " ++ display 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 "Binaries"         (bindir dirs)     (bindir relative)-        dirinfo "Libraries"        (libdir dirs)     (libdir relative)-        dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative)-        dirinfo "Data files"       (datadir dirs)    (datadir relative)-        dirinfo "Documentation"    (docdir dirs)     (docdir relative)--        sequence_ [ reportProgram verbosity prog configuredProg-                  | (prog, configuredProg) <- knownPrograms programsConfig''' ]--        return lbi--    where-      addExtraIncludeLibDirs pkg_descr =-          let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg-                               , PD.includeDirs = configExtraIncludeDirs cfg}-              modifyLib l        = l{ libBuildInfo = libBuildInfo l `mappend` extraBi }-              modifyExecutable e = e{ buildInfo    = buildInfo e    `mappend` extraBi}-          in pkg_descr{ library     = modifyLib        `fmap` library pkg_descr-                      , executables = modifyExecutable  `map` executables pkg_descr}---- -------------------------------------------------------------------------------- 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 " ++ display v--hackageUrl :: String-hackageUrl = "http://hackage.haskell.org/package/"--data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo-                        | InternalDependency Dependency PackageId -- should be a lib name--data FailedDependency = DependencyNotExists PackageName-                      | DependencyNoVersion Dependency---- | Test for a package dependency and record the version we have installed.-selectDependency :: PackageIndex  -- ^ Internally defined packages-                 -> PackageIndex  -- ^ Installed packages-                 -> Dependency-                 -> Either FailedDependency ResolvedDependency-selectDependency internalIndex installedIndex-  dep@(Dependency pkgname vr) =-  -- 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".-  -- However, "build-depends: MyLibrary >= 0.2" should match the installed one.-  case PackageIndex.lookupPackageName internalIndex pkgname of-    [(_,[pkg])] | packageVersion pkg `withinRange` vr-           -> Right $ InternalDependency dep (packageId pkg)--    _      -> case PackageIndex.lookupDependency installedIndex dep of-      []   -> Left  $ DependencyNotExists pkgname-      pkgs -> Right $ ExternalDependency dep $-                -- by default we just pick the latest-                case last pkgs of-                  (_ver, instances) -> head instances -- the first preference--reportSelectedDependencies :: Verbosity-                           -> [ResolvedDependency] -> IO ()-reportSelectedDependencies verbosity deps =-  info verbosity $ unlines-    [ "Dependency " ++ display (simplifyDependency dep)-                    ++ ": using " ++ display pkgid-    | resolved <- deps-    , let (dep, pkgid) = case resolved of-            ExternalDependency dep' pkg'   -> (dep', packageId pkg')-            InternalDependency dep' pkgid' -> (dep', pkgid') ]--reportFailedDependencies :: [FailedDependency] -> IO ()-reportFailedDependencies []     = return ()-reportFailedDependencies failed =-    die (intercalate "\n\n" (map reportFailedDependency failed))--  where-    reportFailedDependency (DependencyNotExists pkgname) =-         "there is no version of " ++ display pkgname ++ " installed.\n"-      ++ "Perhaps you need to download and install it from\n"-      ++ hackageUrl ++ display pkgname ++ "?"--    reportFailedDependency (DependencyNoVersion dep) =-        "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n"--getInstalledPackages :: Verbosity -> Compiler-                     -> PackageDBStack -> ProgramConfiguration-                     -> IO PackageIndex-getInstalledPackages verbosity comp packageDBs progconf = do-  info verbosity "Reading installed packages..."-  case compilerFlavor comp of-    GHC -> GHC.getInstalledPackages verbosity packageDBs progconf-    Hugs->Hugs.getInstalledPackages verbosity packageDBs progconf-    JHC -> JHC.getInstalledPackages verbosity packageDBs progconf-    LHC -> LHC.getInstalledPackages verbosity packageDBs progconf-    NHC -> NHC.getInstalledPackages verbosity packageDBs progconf-    UHC -> UHC.getInstalledPackages verbosity comp packageDBs progconf-    flv -> die $ "don't know how to find the installed packages for "-              ++ display flv---- | Currently the user interface specifies the package dbs to use with just a--- single valued option, a 'PackageDB'. However internally we represent the--- stack of 'PackageDB's explictly as a list. This function converts encodes--- the package db stack implicit in a single packagedb.----implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack-implicitPackageDbStack userInstall maybePackageDB-  | userInstall = GlobalPackageDB : UserPackageDB : extra-  | otherwise   = GlobalPackageDB : extra-  where-    extra = case maybePackageDB of-      Just (SpecificPackageDB db) -> [SpecificPackageDB db]-      _                           -> []--newPackageDepsBehaviourMinVersion :: Version-newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1], versionTags = [] }---- 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--- specified is >= a certain minimum. Otherwise, for compatibility we use the--- old behaviour.-newPackageDepsBehaviour :: PackageDescription -> Bool-newPackageDepsBehaviour pkg =-   specVersion pkg >= newPackageDepsBehaviourMinVersion---- -------------------------------------------------------------------------------- Configuring program dependencies--configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration -> IO ProgramConfiguration-configureRequiredPrograms verbosity deps conf =-  foldM (configureRequiredProgram verbosity) conf deps--configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency -> IO ProgramConfiguration-configureRequiredProgram verbosity conf (Dependency (PackageName progName) verRange) =-  case lookupKnownProgram progName conf of-    Nothing -> die ("Unknown build tool " ++ progName)-    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-          (_, conf') <- requireProgram verbosity prog conf-          return conf'-      | otherwise -> do-          (_, _, conf') <- requireProgramVersion verbosity prog verRange conf-          return conf'---- -------------------------------------------------------------------------------- Configuring pkg-config package dependencies--configurePkgconfigPackages :: Verbosity -> PackageDescription-                           -> ProgramConfiguration-                           -> IO (PackageDescription, ProgramConfiguration)-configurePkgconfigPackages verbosity pkg_descr conf-  | null allpkgs = return (pkg_descr, conf)-  | otherwise    = do-    (_, _, conf') <- requireProgramVersion-                       (lessVerbose verbosity) pkgConfigProgram-                       (orLaterVersion $ Version [0,9,0] []) conf-    mapM_ requirePkg allpkgs-    lib'  <- updateLibrary (library pkg_descr)-    exes' <- mapM updateExecutable (executables pkg_descr)-    let pkg_descr' = pkg_descr { library = lib', executables = exes' }-    return (pkg_descr', conf')--  where-    allpkgs = concatMap pkgconfigDepends (allBuildInfo pkg_descr)-    pkgconfig = rawSystemProgramStdoutConf (lessVerbose verbosity)-                  pkgConfigProgram conf--    requirePkg dep@(Dependency (PackageName pkg) range) = do-      version <- pkgconfig ["--modversion", pkg]-                 `catchIO`   (\_ -> die notFound)-                 `catchExit` (\_ -> die notFound)-      case simpleParse version of-        Nothing -> die "parsing output of pkg-config --modversion failed"-        Just v | not (withinRange v range) -> die (badVersion v)-               | otherwise                 -> 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 " ++ display v-        depSatisfied v = "Dependency " ++ display dep-                      ++ ": using version " ++ display v--        versionRequirement-          | isAnyVersion range = ""-          | otherwise          = " version " ++ display range--    updateLibrary Nothing    = return Nothing-    updateLibrary (Just lib) = do-      bi <- pkgconfigBuildInfo (pkgconfigDepends (libBuildInfo lib))-      return $ Just lib { libBuildInfo = libBuildInfo lib `mappend` bi }--    updateExecutable exe = do-      bi <- pkgconfigBuildInfo (pkgconfigDepends (buildInfo exe))-      return exe { buildInfo = buildInfo exe `mappend` bi }--    pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo-    pkgconfigBuildInfo []      = return mempty-    pkgconfigBuildInfo pkgdeps = do-      let pkgs = nub [ display pkg | Dependency 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 <- rawSystemProgramStdoutConf verbosity prog conf ["--cflags"]--- > ldflags <- rawSystemProgramStdoutConf verbosity prog conf ["--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 {-       PD.includeDirs  = map (drop 2) includeDirs',-       PD.extraLibs    = map (drop 2) extraLibs',-       PD.extraLibDirs = map (drop 2) extraLibDirs',-       PD.ccOptions    = cflags',-       PD.ldOptions    = ldflags''-     }---- -------------------------------------------------------------------------------- Determining the compiler details--configCompilerAux :: ConfigFlags -> IO (Compiler, ProgramConfiguration)-configCompilerAux cfg = configCompiler (flagToMaybe $ configHcFlavor cfg)-                                       (flagToMaybe $ configHcPath cfg)-                                       (flagToMaybe $ configHcPkg cfg)-                                       programsConfig-                                       (fromFlag (configVerbosity cfg))-  where-    programsConfig = userSpecifyArgss (configProgramArgs cfg)-                   . userSpecifyPaths (configProgramPaths cfg)-                   $ defaultProgramConfiguration--configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath-               -> ProgramConfiguration -> Verbosity-               -> IO (Compiler, ProgramConfiguration)-configCompiler Nothing _ _ _ _ = die "Unknown compiler"-configCompiler (Just hcFlavor) hcPath hcPkg conf verbosity = do-  case hcFlavor of-      GHC  -> GHC.configure  verbosity hcPath hcPkg conf-      JHC  -> JHC.configure  verbosity hcPath hcPkg conf-      LHC  -> do (_,ghcConf) <- GHC.configure  verbosity Nothing hcPkg conf-                 LHC.configure  verbosity hcPath Nothing ghcConf-      Hugs -> Hugs.configure verbosity hcPath hcPkg conf-      NHC  -> NHC.configure  verbosity hcPath hcPkg conf-      UHC  -> UHC.configure  verbosity hcPath hcPkg conf-      _    -> die "Unknown compiler"----- 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 = do-  ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling lucky-           (return ())-           (do missingLibs <- findMissingLibs-               missingHdr  <- findOffendingHdr-               explainErrors missingHdr missingLibs)-      where-        allHeaders = collectField PD.includes-        allLibs    = collectField PD.extraLibs--        ifBuildsWith headers args success failure = do-            ok <- builds (makeProgram headers) args-            if ok then success else failure--        findOffendingHdr =-            ifBuildsWith allHeaders ccArgs-                         (return Nothing)-                         (go . tail . 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 . Just . Right . last $ hdrs))-                      (return . Just . Left . last $ 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])--        commonCppArgs = hcDefines (compiler lbi)-                     ++ [ "-I" ++ autogenModulesDir lbi ]-                     ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ]-                     ++ ["-I."]-                     ++ collectField PD.cppOptions-                     ++ collectField PD.ccOptions-                     ++ [ "-I" ++ dir-                        | dep <- deps-                        , dir <- Installed.includeDirs dep ]-                     ++ [ opt-                        | dep <- deps-                        , opt <- Installed.ccOptions dep ]--        commonCcArgs  = commonCppArgs-                     ++ collectField PD.ccOptions-                     ++ [ opt-                        | dep <- deps-                        , opt <- Installed.ccOptions dep ]--        commonLdArgs  = [ "-L" ++ dir | dir <- collectField PD.extraLibDirs ]-                     ++ collectField PD.ldOptions-                     ++ [ "-L" ++ dir-                        | dep <- deps-                        , dir <- Installed.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 = allBuildInfo pkg-        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-                _ <- rawSystemProgramStdoutConf verbosity-                  gccProgram (withPrograms lbi) (cName:"-o":oNname:args)-                return True-           `catchIO`   (\_ -> return False)-           `catchExit` (\_ -> return False)--        explainErrors Nothing [] = return () -- should be impossible!-        explainErrors hdr libs = die $ 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 C library: " ++ lib]-               _     -> ["* Missing 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."-        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."-        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."--        --FIXME: share this with the PreProcessor module-        hcDefines :: Compiler -> [String]-        hcDefines comp =-          case compilerFlavor comp of-            GHC  -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version]-            JHC  -> ["-D__JHC__=" ++ versionInt version]-            NHC  -> ["-D__NHC__=" ++ versionInt version]-            Hugs -> ["-D__HUGS__"]-            _    -> []-          where-            version = compilerVersion 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 (Version { versionBranch = [] }) = "1"-            versionInt (Version { versionBranch = [n] }) = show n-            versionInt (Version { versionBranch = 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---- | Output package check warnings and errors. Exit if any errors.-checkPackageProblems :: Verbosity-                     -> GenericPackageDescription-                     -> PackageDescription-                     -> IO ()-checkPackageProblems verbosity gpkg pkg = do-  ioChecks      <- checkPackageFiles pkg "."-  let pureChecks = checkPackage gpkg (Just pkg)-      errors   = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ]-      warnings = [ w | PackageBuildWarning    w <- pureChecks ++ ioChecks ]-  if null errors-    then mapM_ (warn verbosity) warnings-    else do mapM_ (hPutStrLn stderr . ("Error: " ++)) errors-            exitWith (ExitFailure 1)
− Distribution/Simple/GHC.hs 
@@ -1,1083 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.GHC--- Copyright   :  Isaac Jones 2003-2007------ 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.--{- Copyright (c) 2003-2005, Isaac Jones-All rights reserved.--Redistribution and use in source and binary forms, with or without-modiication, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.GHC (-        configure, getInstalledPackages,-        buildLib, buildExe,-        installLib, installExe,-        libAbiHash,-        registerPackage,-        ghcOptions,-        ghcVerbosityOptions,-        ghcPackageDbOptions,-        ghcLibDir,- ) where--import qualified Distribution.Simple.GHC.IPI641 as IPI641-import qualified Distribution.Simple.GHC.IPI642 as IPI642-import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), Executable(..)-         , Library(..), libModules, hcOptions, usedExtensions, allExtensions )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-                                ( InstalledPackageInfo_(..) )-import Distribution.Simple.PackageIndex (PackageIndex)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-         , absoluteInstallDirs )-import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs )-import Distribution.Simple.BuildPaths-import Distribution.Simple.Utils-import Distribution.Package-         ( PackageIdentifier, Package(..), PackageName(..) )-import qualified Distribution.ModuleName as ModuleName-import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg-         , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf-         , rawSystemProgramStdout, rawSystemProgramStdoutConf-         , requireProgramVersion, requireProgram, getProgramOutput-         , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram-         , ghcProgram, ghcPkgProgram, hsc2hsProgram-         , arProgram, ranlibProgram, ldProgram-         , gccProgram, stripProgram )-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 Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion-         , OptimisationLevel(..), PackageDB(..), PackageDBStack-         , Flag, languageToFlags, extensionsToFlags )-import Distribution.Version-         ( Version(..), anyVersion, orLaterVersion )-import Distribution.System-         ( OS(..), buildOS )-import Distribution.Verbosity-import Distribution.Text-         ( display, simpleParse )-import Language.Haskell.Extension (Language(..), Extension(..), KnownExtension(..))--import Control.Monad            ( unless, when, liftM )-import Data.Char                ( isSpace )-import Data.List-import Data.Maybe               ( catMaybes )-import Data.Monoid              ( Monoid(..) )-import System.Directory-         ( removeFile, getDirectoryContents, doesFileExist-         , getTemporaryDirectory )-import System.FilePath          ( (</>), (<.>), takeExtension,-                                  takeDirectory, replaceExtension, splitExtension )-import System.IO (hClose, hPutStrLn)-import Distribution.Compat.Exception (catchExit, catchIO)---- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)-configure verbosity hcPath hcPkgPath conf0 = do--  (ghcProg, ghcVersion, conf1) <--    requireProgramVersion verbosity ghcProgram-      (orLaterVersion (Version [6,4] []))-      (userMaybeSpecifyPath "ghc" hcPath conf0)--  -- 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, conf2) <--    requireProgramVersion verbosity ghcPkgProgram {-      programFindLocation = guessGhcPkgFromGhcPath ghcProg-    }-    anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath conf1)--  when (ghcVersion /= ghcPkgVersion) $ die $-       "Version mismatch between ghc and ghc-pkg: "-    ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " "-    ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion--  -- Likewise we try to find the matching hsc2hs program.-  let hsc2hsProgram' = hsc2hsProgram {-                           programFindLocation = guessHsc2hsFromGhcPath ghcProg-                       }-      conf3 = addKnownProgram hsc2hsProgram' conf2--  languages  <- getLanguages verbosity ghcProg-  extensions <- getExtensions verbosity ghcProg--  ghcInfo <- if ghcVersion >= Version [6,7] []-             then do xs <- getProgramOutput verbosity ghcProg ["--info"]-                     case reads xs of-                         [(i, ss)]-                          | all isSpace ss ->-                             return i-                         _ ->-                             die "Can't parse --info output of GHC"-             else return []--  let comp = Compiler {-        compilerId             = CompilerId GHC ghcVersion,-        compilerLanguages      = languages,-        compilerExtensions     = extensions-      }-      conf4 = configureToolchain ghcProg ghcInfo conf3 -- configure gcc and ld-  return (comp, conf4)---- | 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 :: FilePath -> ConfiguredProgram -> Verbosity-                     -> IO (Maybe FilePath)-guessToolFromGhcPath tool ghcProg verbosity-  = do let path              = programPath ghcProg-           dir               = takeDirectory path-           versionSuffix     = takeVersionSuffix (dropExeExtension path)-           guessNormal       = dir </> tool <.> exeExtension-           guessGhcVersioned = dir </> (tool ++ "-ghc" ++ versionSuffix) <.> exeExtension-           guessVersioned    = dir </> (tool ++ versionSuffix) <.> exeExtension-           guesses | null versionSuffix = [guessNormal]-                   | otherwise          = [guessGhcVersioned,-                                           guessVersioned,-                                           guessNormal]-       info verbosity $ "looking for tool " ++ show tool ++ " near compiler in " ++ dir-       exists <- mapM doesFileExist guesses-       case [ file | (file, True) <- zip guesses exists ] of-         [] -> return Nothing-         (fp:_) -> do info verbosity $ "found " ++ tool ++ " in " ++ fp-                      return (Just fp)--  where takeVersionSuffix :: FilePath -> String-        takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") . reverse--        dropExeExtension :: FilePath -> FilePath-        dropExeExtension filepath =-          case splitExtension filepath of-            (filepath', extension) | extension == exeExtension -> filepath'-                                   | otherwise                 -> filepath---- | 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 -> IO (Maybe FilePath)-guessGhcPkgFromGhcPath = guessToolFromGhcPath "ghc-pkg"---- | 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 -> IO (Maybe FilePath)-guessHsc2hsFromGhcPath = guessToolFromGhcPath "hsc2hs"---- | Adjust the way we find and configure gcc and ld----configureToolchain :: ConfiguredProgram -> [(String, String)]-                                        -> ProgramConfiguration-                                        -> ProgramConfiguration-configureToolchain ghcProg ghcInfo =-    addKnownProgram gccProgram {-      programFindLocation = findProg gccProgram-                              [ if ghcVersion >= Version [6,12] []-                                  then mingwBinDir </> "gcc.exe"-                                  else baseDir     </> "gcc.exe" ],-      programPostConf     = configureGcc-    }-  . addKnownProgram ldProgram {-      programFindLocation = findProg ldProgram-                              [ if ghcVersion >= Version [6,12] []-                                  then mingwBinDir </> "ld.exe"-                                  else libDir      </> "ld.exe" ],-      programPostConf     = configureLd-    }-  . addKnownProgram arProgram {-      programFindLocation = findProg arProgram-                              [ if ghcVersion >= Version [6,12] []-                                  then mingwBinDir </> "ar.exe"-                                  else libDir      </> "ar.exe" ]-    }-  where-    Just ghcVersion = programVersion ghcProg-    compilerDir = takeDirectory (programPath ghcProg)-    baseDir     = takeDirectory compilerDir-    mingwBinDir = baseDir </> "mingw" </> "bin"-    libDir      = baseDir </> "gcc-lib"-    includeDir  = baseDir </> "include" </> "mingw"-    isWindows   = case buildOS of Windows -> True; _ -> False--    -- on Windows finding and configuring ghc's gcc and ld is a bit special-    findProg :: Program -> [FilePath] -> Verbosity -> IO (Maybe FilePath)-    findProg prog locations-      | isWindows = \verbosity -> look locations verbosity-      | otherwise = programFindLocation prog-      where-        look [] verbosity = do-          warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.")-          programFindLocation prog verbosity-        look (f:fs) verbosity = do-          exists <- doesFileExist f-          if exists then return (Just f)-                    else look fs verbosity--    ccFlags        = getFlags "C compiler flags"-    gccLinkerFlags = getFlags "Gcc Linker flags"-    ldLinkerFlags  = getFlags "Ld Linker flags"--    getFlags key = case lookup key ghcInfo of-                   Nothing -> []-                   Just flags ->-                       case reads flags of-                       [(args, "")] -> args-                       _ -> [] -- XXX Should should be an error really--    configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg]-    configureGcc v cp = liftM (++ (ccFlags ++ gccLinkerFlags))-                      $ configureGcc' v cp--    configureGcc' :: Verbosity -> ConfiguredProgram -> IO [ProgArg]-    configureGcc'-      | isWindows = \_ gccProg -> case programLocation gccProg of-          -- if it's found on system then it means we're using the result-          -- of programFindLocation above rather than a user-supplied path-          -- Pre GHC 6.12, that meant we should add these flags to tell-          -- ghc's gcc where it lives and thus where gcc can find its-          -- various files:-          FoundOnSystem {}-           | ghcVersion < Version [6,11] [] ->-              return ["-B" ++ libDir, "-I" ++ includeDir]-          _ -> return []-      | otherwise = \_ _   -> return []--    configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg]-    configureLd v cp = liftM (++ ldLinkerFlags) $ configureLd' v cp--    -- we need to find out if ld supports the -x flag-    configureLd' :: Verbosity -> ConfiguredProgram -> IO [ProgArg]-    configureLd' verbosity ldProg = do-      tempDir <- getTemporaryDirectory-      ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->-             withTempFile tempDir ".o" $ \testofile testohnd -> do-               hPutStrLn testchnd "int foo() {}"-               hClose testchnd; hClose testohnd-               rawSystemProgram verbosity ghcProg ["-c", testcfile,-                                                   "-o", testofile]-               withTempFile tempDir ".o" $ \testofile' testohnd' ->-                 do-                   hClose testohnd'-                   _ <- rawSystemProgramStdout verbosity ldProg-                     ["-x", "-r", testofile, "-o", testofile']-                   return True-                 `catchIO`   (\_ -> return False)-                 `catchExit` (\_ -> return False)-      if ldx-        then return ["-x"]-        else return []--getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)]-getLanguages _ ghcProg-  -- TODO: should be using --supported-languages rather than hard coding-  | ghcVersion >= Version [7] [] = return [(Haskell98,   "-XHaskell98")-                                          ,(Haskell2010, "-XHaskell2010")]-  | otherwise                    = return [(Haskell98,   "")]-  where-    Just ghcVersion = programVersion ghcProg--getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)]-getExtensions verbosity ghcProg-  | ghcVersion >= Version [6,7] [] = do--    str <- rawSystemStdout verbosity (programPath ghcProg)-              ["--supported-languages"]-    let extStrs = if ghcVersion >= Version [7] []-                  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, "-X" ++ display ext)-                      | Just ext <- map simpleParse extStrs ]-        extensions1 = if ghcVersion >= Version [6,8]  [] &&-                         ghcVersion <  Version [6,10] []-                      then -- ghc-6.8 introduced RecordPuns however it-                           -- should have been NamedFieldPuns. We now-                           -- encourage packages to use NamedFieldPuns-                           -- so for compatability we fake support for-                           -- it in ghc-6.8 by making it an alias for-                           -- the old RecordPuns extension.-                           (EnableExtension  NamedFieldPuns, "-XRecordPuns") :-                           (DisableExtension NamedFieldPuns, "-XNoRecordPuns") :-                           extensions0-                      else extensions0-        extensions2 = if ghcVersion <  Version [7,1] []-                      then -- ghc-7.2 split NondecreasingIndentation off-                           -- into a proper extension. Before that it-                           -- was always on.-                           (EnableExtension  NondecreasingIndentation, "") :-                           (DisableExtension NondecreasingIndentation, "") :-                           extensions1-                      else extensions1-    return extensions2--  | otherwise = return oldLanguageExtensions--  where-    Just ghcVersion = programVersion ghcProg---- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags-oldLanguageExtensions :: [(Extension, Flag)]-oldLanguageExtensions =-    let doFlag (f, (enable, disable)) = [(EnableExtension  f, enable),-                                         (DisableExtension f, disable)]-        fglasgowExts = ("-fglasgow-exts",-                        "") -- This is wrong, but we don't want to turn-                            -- all the extensions off when asked to just-                            -- turn one off-        fFlag flag = ("-f" ++ flag, "-fno-" ++ flag)-    in concatMap doFlag-    [(OverlappingInstances       , fFlag "allow-overlapping-instances")-    ,(TypeSynonymInstances       , fglasgowExts)-    ,(TemplateHaskell            , fFlag "th")-    ,(ForeignFunctionInterface   , fFlag "ffi")-    ,(MonomorphismRestriction    , fFlag "monomorphism-restriction")-    ,(MonoPatBinds               , fFlag "mono-pat-binds")-    ,(UndecidableInstances       , fFlag "allow-undecidable-instances")-    ,(IncoherentInstances        , fFlag "allow-incoherent-instances")-    ,(Arrows                     , fFlag "arrows")-    ,(Generics                   , fFlag "generics")-    ,(ImplicitPrelude            , fFlag "implicit-prelude")-    ,(ImplicitParams             , fFlag "implicit-params")-    ,(CPP                        , ("-cpp", ""{- Wrong -}))-    ,(BangPatterns               , fFlag "bang-patterns")-    ,(KindSignatures             , fglasgowExts)-    ,(RecursiveDo                , fglasgowExts)-    ,(ParallelListComp           , fglasgowExts)-    ,(MultiParamTypeClasses      , fglasgowExts)-    ,(FunctionalDependencies     , fglasgowExts)-    ,(Rank2Types                 , fglasgowExts)-    ,(RankNTypes                 , fglasgowExts)-    ,(PolymorphicComponents      , fglasgowExts)-    ,(ExistentialQuantification  , fglasgowExts)-    ,(ScopedTypeVariables        , fFlag "scoped-type-variables")-    ,(FlexibleContexts           , fglasgowExts)-    ,(FlexibleInstances          , fglasgowExts)-    ,(EmptyDataDecls             , fglasgowExts)-    ,(PatternGuards              , fglasgowExts)-    ,(GeneralizedNewtypeDeriving , fglasgowExts)-    ,(MagicHash                  , fglasgowExts)-    ,(UnicodeSyntax              , fglasgowExts)-    ,(PatternSignatures          , fglasgowExts)-    ,(UnliftedFFITypes           , fglasgowExts)-    ,(LiberalTypeSynonyms        , fglasgowExts)-    ,(TypeOperators              , fglasgowExts)-    ,(GADTs                      , fglasgowExts)-    ,(RelaxedPolyRec             , fglasgowExts)-    ,(ExtendedDefaultRules       , fFlag "extended-default-rules")-    ,(UnboxedTuples              , fglasgowExts)-    ,(DeriveDataTypeable         , fglasgowExts)-    ,(ConstrainedClassMethods    , fglasgowExts)-    ]--getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration-                     -> IO PackageIndex-getInstalledPackages verbosity packagedbs conf = do-  checkPackageDbStack packagedbs-  pkgss <- getInstalledPackages' verbosity packagedbs conf-  topDir <- ghcLibDir' verbosity ghcProg-  let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)-                | (_, pkgs) <- pkgss ]-  return $! hackRtsPackage (mconcat indexes)--  where-    -- 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-    Just ghcProg = lookupProgram ghcProgram conf--    hackRtsPackage index =-      case PackageIndex.lookupPackageName index (PackageName "rts") of-        [(_,[rts])]-           -> PackageIndex.insert (removeMingwIncludeDir rts) index-        _  -> index -- No (or multiple) ghc rts package is registered!!-                    -- Feh, whatever, the ghc testsuite does some crazy stuff.--ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath-ghcLibDir verbosity lbi =-    (reverse . dropWhile isSpace . reverse) `fmap`-     rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"]--ghcLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath-ghcLibDir' verbosity ghcProg =-    (reverse . dropWhile isSpace . reverse) `fmap`-     rawSystemProgramStdout verbosity ghcProg ["--print-libdir"]--checkPackageDbStack :: PackageDBStack -> IO ()-checkPackageDbStack (GlobalPackageDB:rest)-  | GlobalPackageDB `notElem` rest = return ()-checkPackageDbStack _ =-  die $ "GHC.getInstalledPackages: the global package db 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] -> ProgramConfiguration-                     -> IO [(PackageDB, [InstalledPackageInfo])]-getInstalledPackages' verbosity packagedbs conf-  | ghcVersion >= Version [6,9] [] =-  sequence-    [ do pkgs <- HcPkg.dump verbosity ghcPkgProg packagedb-         return (packagedb, pkgs)-    | packagedb <- packagedbs ]--  where-    Just ghcPkgProg = lookupProgram ghcPkgProgram conf-    Just ghcProg    = lookupProgram ghcProgram conf-    Just ghcVersion = programVersion ghcProg--getInstalledPackages' verbosity packagedbs conf = do-    str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf ["list"]-    let pkgFiles = [ init line | line <- lines str, last line == ':' ]-        dbFile packagedb = case (packagedb, pkgFiles) of-          (GlobalPackageDB, global:_)      -> return $ Just global-          (UserPackageDB,  _global:user:_) -> return $ Just user-          (UserPackageDB,  _global:_)      -> return $ Nothing-          (SpecificPackageDB specific, _)  -> return $ Just specific-          _ -> die "cannot read ghc-pkg package listing"-    pkgFiles' <- mapM dbFile packagedbs-    sequence [ withFileContents file $ \content -> do-                  pkgs <- readPackages file content-                  return (db, pkgs)-             | (db , Just file) <- zip packagedbs pkgFiles' ]-  where-    -- Depending on the version of ghc we use a different type's Read-    -- instance to parse the package file and then convert.-    -- It's a bit yuck. But that's what we get for using Read/Show.-    readPackages-      | ghcVersion >= Version [6,4,2] []-      = \file content -> case reads content of-          [(pkgs, _)] -> return (map IPI642.toCurrent pkgs)-          _           -> failToRead file-      | otherwise-      = \file content -> case reads content of-          [(pkgs, _)] -> return (map IPI641.toCurrent pkgs)-          _           -> failToRead file-    Just ghcProg = lookupProgram ghcProgram conf-    Just ghcVersion = programVersion ghcProg-    failToRead file = die $ "cannot read ghc package database " ++ file--substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo-substTopDir topDir ipo- = ipo {-       InstalledPackageInfo.importDirs-           = map f (InstalledPackageInfo.importDirs ipo),-       InstalledPackageInfo.libraryDirs-           = map f (InstalledPackageInfo.libraryDirs ipo),-       InstalledPackageInfo.includeDirs-           = map f (InstalledPackageInfo.includeDirs ipo),-       InstalledPackageInfo.frameworkDirs-           = map f (InstalledPackageInfo.frameworkDirs ipo),-       InstalledPackageInfo.haddockInterfaces-           = map f (InstalledPackageInfo.haddockInterfaces ipo),-       InstalledPackageInfo.haddockHTMLs-           = map f (InstalledPackageInfo.haddockHTMLs ipo)-   }-    where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest-          f x = x---- -------------------------------------------------------------------------------- Building---- | Build a library with GHC.----buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity pkg_descr lbi lib clbi = do-  let pref = buildDir lbi-      pkgid = packageId pkg_descr-      runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi)-      ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi)-      ifProfLib = when (withProfLib lbi)-      ifSharedLib = when (withSharedLib lbi)-      ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi)-      comp = compiler lbi-      ghcVersion = compilerVersion comp--  libBi <- hackThreadedFlag verbosity-             comp (withProfLib lbi) (libBuildInfo lib)--  let libTargetDir = pref-      forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi-      -- TH always needs vanilla libs, even when building for profiling--  createDirectoryIfMissingVerbose verbosity True libTargetDir-  -- TODO: do we need to put hs-boot files into place for mutually recurive modules?-  let ghcArgs =-             "--make"-          :  ["-package-name", display pkgid ]-          ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity-          ++ map display (libModules lib)-      ghcArgsProf = ghcArgs-          ++ ["-prof",-              "-hisuf", "p_hi",-              "-osuf", "p_o"-             ]-          ++ ghcProfOptions libBi-      ghcArgsShared = ghcArgs-          ++ ["-dynamic",-              "-hisuf", "dyn_hi",-              "-osuf", "dyn_o", "-fPIC"-             ]-          ++ ghcSharedOptions libBi-  unless (null (libModules lib)) $-    do ifVanillaLib forceVanillaLib (runGhcProg ghcArgs)-       ifProfLib (runGhcProg ghcArgsProf)-       ifSharedLib (runGhcProg ghcArgsShared)--  -- build any C sources-  unless (null (cSources libBi)) $ do-     info verbosity "Building C Sources..."-     sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref-                                                        filename verbosity-                                                        False-                                                        (withProfLib lbi)-                   createDirectoryIfMissingVerbose verbosity True odir-                   runGhcProg args-                   ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"]))-               | filename <- cSources libBi]--  -- link:-  info verbosity "Linking..."-  let cObjs = map (`replaceExtension` objExtension) (cSources libBi)-      cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi)-      vanillaLibFilePath = libTargetDir </> mkLibName pkgid-      profileLibFilePath = libTargetDir </> mkProfLibName pkgid-      sharedLibFilePath  = libTargetDir </> mkSharedLibName pkgid-                                              (compilerId (compiler lbi))-      ghciLibFilePath    = libTargetDir </> mkGHCiLibName pkgid-      libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest-      sharedLibInstallPath = libInstallPath </> mkSharedLibName pkgid-                                              (compilerId (compiler lbi))--  stubObjs <- fmap catMaybes $ sequence-    [ findFileWithExtension [objExtension] [libTargetDir]-        (ModuleName.toFilePath x ++"_stub")-    | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files-    , x <- libModules lib ]-  stubProfObjs <- fmap catMaybes $ sequence-    [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]-        (ModuleName.toFilePath x ++"_stub")-    | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files-    , x <- libModules lib ]-  stubSharedObjs <- fmap catMaybes $ sequence-    [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]-        (ModuleName.toFilePath x ++"_stub")-    | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files-    , x <- libModules lib ]--  hObjs     <- getHaskellObjects lib lbi-                    pref objExtension True-  hProfObjs <--    if (withProfLib lbi)-            then getHaskellObjects lib lbi-                    pref ("p_" ++ objExtension) True-            else return []-  hSharedObjs <--    if (withSharedLib lbi)-            then getHaskellObjects lib lbi-                    pref ("dyn_" ++ objExtension) False-            else return []--  unless (null hObjs && null cObjs && null stubObjs) $ do-    -- first remove library files if they exists-    sequence_-      [ removeFile libFilePath `catchIO` \_ -> return ()-      | libFilePath <- [vanillaLibFilePath, profileLibFilePath-                       ,sharedLibFilePath,  ghciLibFilePath] ]--    let staticObjectFiles =-               hObjs-            ++ map (pref </>) cObjs-            ++ stubObjs-        profObjectFiles =-               hProfObjs-            ++ map (pref </>) cObjs-            ++ stubProfObjs-        ghciObjFiles =-               hObjs-            ++ map (pref </>) cObjs-            ++ stubObjs-        dynamicObjectFiles =-               hSharedObjs-            ++ map (pref </>) 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 =-            [ "-no-auto-link-packages",-              "-shared",-              "-dynamic",-              "-o", sharedLibFilePath ]-            -- For dynamic libs, Mac OS/X needs to know the install location-            -- at build time.-            ++ (if buildOS == OSX-                then ["-dylib-install-name", sharedLibInstallPath]-                else [])-            ++ dynamicObjectFiles-            ++ ["-package-name", display pkgid ]-            ++ ghcPackageFlags lbi clbi-            ++ ["-l"++extraLib | extraLib <- extraLibs libBi]-            ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi]--    ifVanillaLib False $ do-      (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi)-      Ar.createArLibArchive verbosity arProg-        vanillaLibFilePath staticObjectFiles--    ifProfLib $ do-      (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi)-      Ar.createArLibArchive verbosity arProg-        profileLibFilePath profObjectFiles--    ifGHCiLib $ do-      (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)-      Ld.combineObjectFiles verbosity ldProg-        ghciLibFilePath ghciObjFiles--    ifSharedLib $-      runGhcProg ghcSharedLinkArgs----- | Build an executable with GHC.----buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity _pkg_descr lbi-  exe@Executable { exeName = exeName', modulePath = modPath } clbi = do-  let pref = buildDir lbi-      runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi)--  exeBi <- hackThreadedFlag verbosity-             (compiler lbi) (withProfExe lbi) (buildInfo exe)--  -- exeNameReal, the name that GHC really uses (with .exe on Windows)-  let exeNameReal = exeName' <.>-                    (if null $ takeExtension exeName' then exeExtension else "")--  let targetDir = pref </> exeName'-  let exeDir    = targetDir </> (exeName' ++ "-tmp")-  createDirectoryIfMissingVerbose verbosity True targetDir-  createDirectoryIfMissingVerbose verbosity True exeDir-  -- TODO: do we need to put hs-boot files into place for mutually recursive modules?-  -- FIX: what about exeName.hi-boot?--  -- build executables-  unless (null (cSources exeBi)) $ do-   info verbosity "Building C Sources."-   sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi-                                          exeDir filename verbosity-                                          (withDynExe lbi) (withProfExe lbi)-                 createDirectoryIfMissingVerbose verbosity True odir-                 runGhcProg args-             | filename <- cSources exeBi]--  srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath--  let cObjs = map (`replaceExtension` objExtension) (cSources exeBi)-  let binArgs linkExe dynExe profExe =-             "--make"-          :  (if linkExe-                 then ["-o", targetDir </> exeNameReal]-                 else ["-c"])-          ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity-          ++ [exeDir </> x | x <- cObjs]-          ++ [srcMainFile]-          ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi]-          ++ ["-l"++lib | lib <- extraLibs exeBi]-          ++ ["-L"++libDir | libDir <- extraLibDirs exeBi]-          ++ concat [["-framework", f] | f <- PD.frameworks exeBi]-          ++ if dynExe-                then ["-dynamic"]-                else []-          ++ if profExe-                then ["-prof",-                      "-hisuf", "p_hi",-                      "-osuf", "p_o"-                     ] ++ ghcProfOptions exeBi-                else []--  -- For building exe's for profiling that use TH we actually-  -- have to build twice, once without profiling and the again-  -- with profiling. 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.-  when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi)-     (runGhcProg (binArgs False (withDynExe lbi) False))--  runGhcProg (binArgs True (withDynExe lbi) (withProfExe lbi))---- | Filter the "-threaded" flag when profiling as it does not---   work with ghc-6.8 and older.-hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo-hackThreadedFlag verbosity comp prof bi-  | not mustFilterThreaded = return bi-  | otherwise              = do-    warn verbosity $ "The ghc flag '-threaded' is not compatible with "-                  ++ "profiling in ghc-6.8 and older. It will be disabled."-    return bi { options = filterHcOptions (/= "-threaded") (options bi) }-  where-    mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] []-                      && "-threaded" `elem` hcOptions GHC bi-    filterHcOptions p hcoptss =-      [ (hc, if hc == GHC then filter p opts else opts)-      | (hc, opts) <- hcoptss ]---- when using -split-objs, we need to search for object files in the--- Module_split directory for each module.-getHaskellObjects :: Library -> LocalBuildInfo-                  -> FilePath -> String -> Bool -> IO [FilePath]-getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs-  | splitObjs lbi && allow_split_objs = do-        let splitSuffix = if compilerVersion (compiler lbi) <-                             Version [6, 11] []-                          then "_split"-                          else "_" ++ wanted_obj_ext ++ "_split"-            dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)-                   | x <- libModules lib ]-        objss <- mapM 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 <- libModules lib ]---- | 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-  libBi <- hackThreadedFlag verbosity-             (compiler lbi) (withProfLib lbi) (libBuildInfo lib)-  let-      ghcArgs =-             "--abi-hash"-          :  ["-package-name", display (packageId pkg_descr) ]-          ++ constructGHCCmdLine lbi libBi clbi (buildDir lbi) verbosity-          ++ map display (exposedModules lib)-  ---  rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ghcArgs---constructGHCCmdLine-        :: LocalBuildInfo-        -> BuildInfo-        -> ComponentLocalBuildInfo-        -> FilePath-        -> Verbosity-        -> [String]-constructGHCCmdLine lbi bi clbi odir verbosity =-        ghcVerbosityOptions verbosity-        -- Unsupported extensions have already been checked by configure-     ++ ghcOptions lbi bi clbi odir--ghcVerbosityOptions :: Verbosity -> [String]-ghcVerbosityOptions verbosity-     | verbosity >= deafening = ["-v"]-     | verbosity >= normal    = []-     | otherwise              = ["-w", "-v0"]--ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo-           -> FilePath -> [String]-ghcOptions lbi bi clbi odir-     =  ["-hide-all-packages"]-     ++ ["-fbuilding-cabal-package" | ghcVer >= Version [6,11] [] ]-     ++ ghcPackageDbOptions (withPackageDB lbi)-     ++ ["-split-objs" | splitObjs lbi ]-     ++ ["-i"]-     ++ ["-i" ++ odir]-     ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]-     ++ ["-i" ++ autogenModulesDir lbi]-     ++ ["-I" ++ autogenModulesDir lbi]-     ++ ["-I" ++ odir]-     ++ ["-I" ++ dir | dir <- PD.includeDirs bi]-     ++ ["-optP" ++ opt | opt <- cppOptions bi]-     ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi </> cppHeaderName) ]-     ++ [ "-#include \"" ++ inc ++ "\"" | ghcVer < Version [6,11] []-                                        , inc <- PD.includes bi ]-     ++ [ "-odir",  odir, "-hidir", odir ]-     ++ concat [ ["-stubdir", odir] | ghcVer >=  Version [6,8] [] ]-     ++ ghcPackageFlags lbi clbi-     ++ (case withOptimization lbi of-           NoOptimisation      -> []-           NormalOptimisation  -> ["-O"]-           MaximumOptimisation -> ["-O2"])-     ++ hcOptions GHC bi-     ++ languageToFlags   (compiler lbi) (defaultLanguage bi)-     ++ extensionsToFlags (compiler lbi) (usedExtensions bi)-    where-      ghcVer = compilerVersion (compiler lbi)--ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String]-ghcPackageFlags lbi clbi-  | ghcVer >= Version [6,11] []-              = concat [ ["-package-id", display ipkgid]-                       | (ipkgid, _) <- componentPackageDeps clbi ]--  | otherwise = concat [ ["-package", display pkgid]-                       | (_, pkgid)  <- componentPackageDeps clbi ]-    where-      ghcVer = compilerVersion (compiler lbi)--ghcPackageDbOptions :: PackageDBStack -> [String]-ghcPackageDbOptions 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)--constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo-                   -> FilePath -> FilePath -> Verbosity -> Bool -> Bool-                   ->(FilePath,[String])-constructCcCmdLine lbi bi clbi pref filename verbosity dynamic profiling-  =  let odir | compilerVersion (compiler lbi) >= Version [6,4,1] []  = pref-              | otherwise = pref </> takeDirectory filename-                        -- ghc 6.4.1 fixed a bug in -odir handling-                        -- for C compilations.-     in-        (odir,-         ghcCcOptions lbi bi clbi odir-         ++ (if verbosity >= deafening then ["-v"] else [])-         ++ ["-c",filename]-         -- Note: When building with profiling enabled, we pass the -prof-         -- option to ghc here when compiling C code, so that the PROFILING-         -- macro gets defined. The macro is used in ghc's Rts.h in the-         -- definitions of closure layouts (Closures.h).-         ++ ["-dynamic" | dynamic]-         ++ ["-prof" | profiling])--ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo-             -> FilePath -> [String]-ghcCcOptions lbi bi clbi odir-     =  ["-I" ++ dir | dir <- odir : PD.includeDirs bi]-     ++ ghcPackageDbOptions (withPackageDB lbi)-     ++ ghcPackageFlags lbi clbi-     ++ ["-optc" ++ opt | opt <- PD.ccOptions bi]-     ++ (case withOptimization lbi of-           NoOptimisation -> []-           _              -> ["-optc-O2"])-     ++ ["-odir", odir]--mkGHCiLibName :: PackageIdentifier -> String-mkGHCiLibName lib = "HS" ++ display lib <.> "o"---- -------------------------------------------------------------------------------- Installing---- |Install executables for GHC.-installExe :: Verbosity-           -> LocalBuildInfo-           -> InstallDirs FilePath -- ^Where to copy the files to-           -> FilePath  -- ^Build location-           -> (FilePath, FilePath)  -- ^Executable (prefix,suffix)-           -> PackageDescription-           -> Executable-           -> IO ()-installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do-  let binDir = bindir installDirs-  createDirectoryIfMissingVerbose verbosity True binDir-  let exeFileName = exeName exe <.> exeExtension-      fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix-      installBinary dest = do-          installExecutableFile verbosity-            (buildPref </> exeName exe </> exeFileName)-            (dest <.> exeExtension)-          stripExe verbosity lbi exeFileName (dest <.> exeExtension)-  installBinary (binDir </> fixedExeBaseName)--stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO ()-stripExe verbosity lbi name path = when (stripExes lbi) $-  case lookupProgram stripProgram (withPrograms lbi) of-    Just strip -> rawSystemProgram verbosity strip args-    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 '" ++ name-                                ++ "' (missing the 'strip' program)"-  where-    args = path : case buildOS 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.-       _   -> []---- |Install for ghc, .hi, .a and, if --with-ghci given, .o-installLib    :: Verbosity-              -> LocalBuildInfo-              -> FilePath  -- ^install location-              -> FilePath  -- ^install location for dynamic librarys-              -> FilePath  -- ^Build location-              -> PackageDescription-              -> Library-              -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do-  -- copy .hi files over:-  let copyHelper installFun src dst n = do-        createDirectoryIfMissingVerbose verbosity True dst-        installFun verbosity (src </> n) (dst </> n)-      copy       = copyHelper installOrdinaryFile-      copyShared = copyHelper installExecutableFile-      copyModuleFiles ext =-        findModuleFiles [builtDir] [ext] (libModules lib)-          >>= installOrdinaryFiles verbosity targetDir-  ifVanilla $ copyModuleFiles "hi"-  ifProf    $ copyModuleFiles "p_hi"-  ifShared  $ copyModuleFiles "dyn_hi"--  -- copy the built library files over:-  ifVanilla $ copy builtDir targetDir vanillaLibName-  ifProf    $ copy builtDir targetDir profileLibName-  ifGHCi    $ copy builtDir targetDir ghciLibName-  ifShared  $ copyShared builtDir dynlibTargetDir sharedLibName--  -- run ranlib if necessary:-  ifVanilla $ updateLibArchive verbosity lbi-                               (targetDir </> vanillaLibName)-  ifProf    $ updateLibArchive verbosity lbi-                               (targetDir </> profileLibName)--  where-    vanillaLibName = mkLibName pkgid-    profileLibName = mkProfLibName pkgid-    ghciLibName    = mkGHCiLibName pkgid-    sharedLibName  = mkSharedLibName pkgid (compilerId (compiler lbi))--    pkgid          = packageId pkg--    hasLib    = not $ null (libModules lib)-                   && null (cSources (libBuildInfo lib))-    ifVanilla = when (hasLib && withVanillaLib lbi)-    ifProf    = when (hasLib && withProfLib    lbi)-    ifGHCi    = when (hasLib && withGHCiLib    lbi)-    ifShared  = when (hasLib && withSharedLib  lbi)---- | On MacOS X we have to call @ranlib@ to regenerate the archive index after--- copying. This is because the silly MacOS X linker checks that the archive--- index is not older than the file itself, which means simply--- copying/installing the file breaks it!!----updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()-updateLibArchive verbosity lbi path-  | buildOS == OSX = do-    (ranlib, _) <- requireProgram verbosity ranlibProgram (withPrograms lbi)-    rawSystemProgram verbosity ranlib [path]-  | otherwise = return ()----- -------------------------------------------------------------------------------- Registering--registerPackage-  :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool-  -> PackageDBStack-  -> IO ()-registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do-  let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)-  HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo)
− Distribution/Simple/GHC/IPI641.hs 
@@ -1,129 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.GHC.IPI641--- Copyright   :  (c) The University of Glasgow 2004------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable-----{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of the University nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.GHC.IPI641 (-    InstalledPackageInfo,-    toCurrent,-  ) where--import qualified Distribution.InstalledPackageInfo as Current-import qualified Distribution.Package as Current hiding (depends)-import Distribution.Text (display)--import Distribution.Simple.GHC.IPI642-         ( PackageIdentifier, convertPackageId-         , License, convertLicense, convertModuleName )---- | This is the InstalledPackageInfo type used by ghc-6.4 and 6.4.1.------ It's here purely for the 'Read' instance so that we can read the package--- database used by those ghc versions. It is a little hacky to read the--- package db directly, but we do need the info and until ghc-6.9 there was--- no better method.------ In ghc-6.4.2 the format changed a bit. See "Distribution.Simple.GHC.IPI642"----data InstalledPackageInfo = InstalledPackageInfo {-    package           :: PackageIdentifier,-    license           :: License,-    copyright         :: String,-    maintainer        :: String,-    author            :: String,-    stability         :: String,-    homepage          :: String,-    pkgUrl            :: String,-    description       :: String,-    category          :: String,-    exposed           :: Bool,-    exposedModules    :: [String],-    hiddenModules     :: [String],-    importDirs        :: [FilePath],-    libraryDirs       :: [FilePath],-    hsLibraries       :: [String],-    extraLibraries    :: [String],-    includeDirs       :: [FilePath],-    includes          :: [String],-    depends           :: [PackageIdentifier],-    hugsOptions       :: [String],-    ccOptions         :: [String],-    ldOptions         :: [String],-    frameworkDirs     :: [FilePath],-    frameworks        :: [String],-    haddockInterfaces :: [FilePath],-    haddockHTMLs      :: [FilePath]-  }-  deriving Read--mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId-mkInstalledPackageId = Current.InstalledPackageId . display--toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo-toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo {-    Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)),-    Current.sourcePackageId    = convertPackageId (package ipi),-    Current.license            = convertLicense (license ipi),-    Current.copyright          = copyright ipi,-    Current.maintainer         = maintainer ipi,-    Current.author             = author ipi,-    Current.stability          = stability ipi,-    Current.homepage           = homepage ipi,-    Current.pkgUrl             = pkgUrl ipi,-    Current.synopsis           = "",-    Current.description        = description ipi,-    Current.category           = category ipi,-    Current.exposed            = exposed ipi,-    Current.exposedModules     = map convertModuleName (exposedModules ipi),-    Current.hiddenModules      = map convertModuleName (hiddenModules ipi),-    Current.trusted            = Current.trusted Current.emptyInstalledPackageInfo,-    Current.importDirs         = importDirs ipi,-    Current.libraryDirs        = libraryDirs ipi,-    Current.hsLibraries        = hsLibraries ipi,-    Current.extraLibraries     = extraLibraries ipi,-    Current.extraGHCiLibraries = [],-    Current.includeDirs        = includeDirs ipi,-    Current.includes           = includes ipi,-    Current.depends            = map (mkInstalledPackageId.convertPackageId) (depends ipi),-    Current.hugsOptions        = hugsOptions ipi,-    Current.ccOptions          = ccOptions ipi,-    Current.ldOptions          = ldOptions ipi,-    Current.frameworkDirs      = frameworkDirs ipi,-    Current.frameworks         = frameworks ipi,-    Current.haddockInterfaces  = haddockInterfaces ipi,-    Current.haddockHTMLs       = haddockHTMLs ipi-  }
− Distribution/Simple/GHC/IPI642.hs 
@@ -1,164 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.GHC.IPI642--- Copyright   :  (c) The University of Glasgow 2004------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable-----{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of the University nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.GHC.IPI642 (-    InstalledPackageInfo,-    toCurrent,--    -- Don't use these, they're only for conversion purposes-    PackageIdentifier, convertPackageId,-    License, convertLicense,-    convertModuleName-  ) where--import qualified Distribution.InstalledPackageInfo as Current-import qualified Distribution.Package as Current hiding (depends)-import qualified Distribution.License as Current--import Distribution.Version (Version)-import Distribution.ModuleName (ModuleName)-import Distribution.Text (simpleParse,display)--import Data.Maybe---- | This is the InstalledPackageInfo type used by ghc-6.4.2 and later.------ It's here purely for the 'Read' instance so that we can read the package--- database used by those ghc versions. It is a little hacky to read the--- package db directly, but we do need the info and until ghc-6.9 there was--- no better method.------ In ghc-6.4.1 and before the format was slightly different.--- See "Distribution.Simple.GHC.IPI642"----data InstalledPackageInfo = InstalledPackageInfo {-    package           :: PackageIdentifier,-    license           :: License,-    copyright         :: String,-    maintainer        :: String,-    author            :: String,-    stability         :: String,-    homepage          :: String,-    pkgUrl            :: String,-    description       :: String,-    category          :: String,-    exposed           :: Bool,-    exposedModules    :: [String],-    hiddenModules     :: [String],-    importDirs        :: [FilePath],-    libraryDirs       :: [FilePath],-    hsLibraries       :: [String],-    extraLibraries    :: [String],-    extraGHCiLibraries:: [String],-    includeDirs       :: [FilePath],-    includes          :: [String],-    depends           :: [PackageIdentifier],-    hugsOptions       :: [String],-    ccOptions         :: [String],-    ldOptions         :: [String],-    frameworkDirs     :: [FilePath],-    frameworks        :: [String],-    haddockInterfaces :: [FilePath],-    haddockHTMLs      :: [FilePath]-  }-  deriving Read--data PackageIdentifier = PackageIdentifier {-    pkgName    :: String,-    pkgVersion :: Version-  }-  deriving Read--data License = GPL | LGPL | BSD3 | BSD4-             | PublicDomain | AllRightsReserved | OtherLicense-  deriving Read--convertPackageId :: PackageIdentifier -> Current.PackageIdentifier-convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } =-  Current.PackageIdentifier (Current.PackageName n) v--mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId-mkInstalledPackageId = Current.InstalledPackageId . display--convertModuleName :: String -> ModuleName-convertModuleName s = fromJust $ simpleParse s--convertLicense :: License -> Current.License-convertLicense GPL  = Current.GPL  Nothing-convertLicense LGPL = Current.LGPL Nothing-convertLicense BSD3 = Current.BSD3-convertLicense BSD4 = Current.BSD4-convertLicense PublicDomain = Current.PublicDomain-convertLicense AllRightsReserved = Current.AllRightsReserved-convertLicense OtherLicense = Current.OtherLicense--toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo-toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo {-    Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)),-    Current.sourcePackageId    = convertPackageId (package ipi),-    Current.license            = convertLicense (license ipi),-    Current.copyright          = copyright ipi,-    Current.maintainer         = maintainer ipi,-    Current.author             = author ipi,-    Current.stability          = stability ipi,-    Current.homepage           = homepage ipi,-    Current.pkgUrl             = pkgUrl ipi,-    Current.synopsis           = "",-    Current.description        = description ipi,-    Current.category           = category ipi,-    Current.exposed            = exposed ipi,-    Current.exposedModules     = map convertModuleName (exposedModules ipi),-    Current.hiddenModules      = map convertModuleName (hiddenModules ipi),-    Current.trusted            = Current.trusted Current.emptyInstalledPackageInfo,-    Current.importDirs         = importDirs ipi,-    Current.libraryDirs        = libraryDirs ipi,-    Current.hsLibraries        = hsLibraries ipi,-    Current.extraLibraries     = extraLibraries ipi,-    Current.extraGHCiLibraries = extraGHCiLibraries ipi,-    Current.includeDirs        = includeDirs ipi,-    Current.includes           = includes ipi,-    Current.depends            = map (mkInstalledPackageId.convertPackageId) (depends ipi),-    Current.hugsOptions        = hugsOptions ipi,-    Current.ccOptions          = ccOptions ipi,-    Current.ldOptions          = ldOptions ipi,-    Current.frameworkDirs      = frameworkDirs ipi,-    Current.frameworks         = frameworks ipi,-    Current.haddockInterfaces  = haddockInterfaces ipi,-    Current.haddockHTMLs       = haddockHTMLs ipi-  }
− Distribution/Simple/Haddock.hs 
@@ -1,638 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Haddock--- Copyright   :  Isaac Jones 2003-2005------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module deals with the @haddock@ and @hscolour@ commands. Sadly this is--- a rather complicated module. It deals with two versions of haddock (0.x and--- 2.x). It has to do pre-processing for haddock 0.x which involves--- \'unlit\'ing and using @-DHADDOCK@ for any source code that uses @cpp@. 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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.Haddock (-  haddock, hscolour-  ) where---- local-import Distribution.Package-         ( PackageIdentifier, Package(..), packageName )-import qualified Distribution.ModuleName as ModuleName-import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), allExtensions-         , Library(..), hasLibs, Executable(..) )-import Distribution.Simple.Compiler-         ( Compiler(..), compilerVersion )-import Distribution.Simple.GHC ( ghcLibDir )-import Distribution.Simple.Program-         ( ConfiguredProgram(..), requireProgramVersion-         , rawSystemProgram, rawSystemProgramStdout-         , hscolourProgram, haddockProgram )-import Distribution.Simple.PreProcess (ppCpp', ppUnlit-                                      , PPSuffixHandler, runSimplePreProcessor-                                      , preprocessComponent)-import Distribution.Simple.Setup-        ( defaultHscolourFlags, Flag(..), flagToMaybe, fromFlag-        , HaddockFlags(..), HscolourFlags(..) )-import Distribution.Simple.Build (initialBuildSteps)-import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplateEnv, PathTemplate,-                                        PathTemplateVariable(..),-                                        toPathTemplate, fromPathTemplate,-                                        substPathTemplate,-                                        initialPathTemplateEnv)-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), externalPackageDeps-         , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI )-import Distribution.Simple.BuildPaths ( haddockName,-                                        hscolourPref, autogenModulesDir,-                                        )-import Distribution.Simple.PackageIndex (dependencyClosure)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-         ( InstalledPackageInfo_(..) )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import Distribution.Simple.Utils-         ( die, warn, notice, intercalate, setupMessage-         , createDirectoryIfMissingVerbose, withTempFile, copyFileVerbose-         , withTempDirectory-         , findFileWithExtension, findFile )-import Distribution.Simple.GHC (ghcOptions)-import Distribution.Text-         ( display, simpleParse )--import Distribution.Verbosity-import Language.Haskell.Extension--- Base-import System.Directory(removeFile, doesFileExist, createDirectoryIfMissing)--import Control.Monad ( when, guard )-import Control.Exception (assert)-import Data.Monoid-import Data.Maybe    ( fromMaybe, listToMaybe )--import System.FilePath((</>), (<.>), splitFileName, splitExtension,-                       normalise, splitPath, joinPath)-import System.IO (hClose, hPutStrLn)-import Distribution.Version---- Types---- | record that represents the arguments to the haddock executable, a product monoid.-data HaddockArgs = HaddockArgs {- argInterfaceFile :: Flag FilePath,               -- ^ path of the interface file, relative to argOutputDir, required.- argPackageName :: Flag PackageIdentifier,        -- ^ package name,                                         required.- argHideModules :: (All,[ModuleName.ModuleName]), -- ^ (hide modules ?, modules to hide)- argIgnoreExports :: Any,                         -- ^ ingore export lists in modules?- argLinkSource :: Flag (Template,Template),       -- ^ (template for modules, template for symbols)- argCssFile :: Flag FilePath,                     -- ^ optinal 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 FilePath)],   -- ^ [(interface file, path to the html docs for links)]- argOutputDir :: Directory,                       -- ^ where to generate the documentation.- argTitle :: Flag String,                         -- ^ page's title,                                         required.- argPrologue :: Flag String,                      -- ^ prologue text,                                        required.- argGhcFlags :: [String],                         -- ^ additional flags to pass to ghc for haddock-2- argGhcLibDir :: Flag FilePath,                   -- ^ to find the correct ghc,                              required by haddock-2.- argTargets :: [FilePath]                         -- ^ modules to process.-}---- | the FilePath of a directory, it's a monoid under (</>)-newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord)--unDir :: Directory -> FilePath-unDir = joinPath . filter (\p -> p /="./" && p /= ".") . splitPath . 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) =-      warn (fromFlag $ haddockVerbosity haddockFlags) $-           "No documentation was generated as this package does not contain "-        ++ "a library. Perhaps you want to use the --executables flag."--haddock pkg_descr lbi suffixes flags = do--    setupMessage verbosity "Running Haddock for" (packageId pkg_descr)-    (confHaddock, version, _) <--      requireProgramVersion verbosity haddockProgram-        (orLaterVersion (Version [0,6] [])) (withPrograms lbi)--    -- various sanity checks-    let isVersion2   = version >= Version [2,0] []--    when ( flag haddockHoogle-           && version > Version [2] []-           && version < Version [2,2] []) $-         die "haddock 2.0 and 2.1 do not support the --hoogle flag."--    when (flag haddockHscolour && version < Version [0,8] []) $-         die "haddock --hyperlink-source requires Haddock version 0.8 or later"--    when isVersion2 $ do-      haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock-                                ["--ghc-version"]-      case simpleParse haddockGhcVersionStr of-        Nothing -> die "Could not get GHC version from Haddock"-        Just haddockGhcVersion-          | haddockGhcVersion == ghcVersion -> return ()-          | otherwise -> die $-                 "Haddock's internal GHC version must match the configured "-              ++ "GHC version.\n"-              ++ "The GHC version is " ++ display ghcVersion ++ " but "-              ++ "haddock is using GHC version " ++ display haddockGhcVersion-          where ghcVersion = compilerVersion (compiler lbi)--    -- the tools match the requests, we can proceed--    initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity--    when (flag haddockHscolour) $ hscolour' pkg_descr lbi suffixes $-         defaultHscolourFlags `mappend` haddockToHscolour flags--    args <- fmap mconcat . sequence $-            [ getInterfaces verbosity lbi (flagToMaybe (haddockHtmlLocation flags))-            , getGhcLibDir  verbosity lbi isVersion2 ]-           ++ map return-            [ fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags-            , fromPackageDescription pkg_descr ]--    let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes-    withComponentsLBI pkg_descr lbi $ \comp clbi -> do-      pre comp-      case comp of-        CLib lib -> do-          withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do-            let bi = libBuildInfo lib-            libArgs  <- fromLibrary tmp lbi lib clbi-            libArgs' <- prepareSources verbosity tmp-                          lbi isVersion2 bi (args `mappend` libArgs)-            runHaddock verbosity confHaddock libArgs'-        CExe exe -> when (flag haddockExecutables) $ do-          withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do-            let bi = buildInfo exe-            exeArgs  <- fromExecutable tmp lbi exe clbi-            exeArgs' <- prepareSources verbosity tmp-                          lbi isVersion2 bi (args `mappend` exeArgs)-            runHaddock verbosity confHaddock exeArgs'-        _ -> return ()-  where-    verbosity = flag haddockVerbosity-    flag f    = fromFlag $ f flags---- | performs cpp and unlit preprocessing where needed on the files in--- | argTargets, which must have an .hs or .lhs extension.-prepareSources :: Verbosity-                  -> FilePath-                  -> LocalBuildInfo-                  -> Bool            -- haddock == 2.*-                  -> BuildInfo-                  -> HaddockArgs-                  -> IO HaddockArgs-prepareSources verbosity tmp lbi isVersion2 bi args@HaddockArgs{argTargets=files} =-              mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets}-          where-            mockPP pref file = do-                 let (filePref, fileName) = splitFileName file-                     targetDir  = pref </> filePref-                     targetFile = targetDir </> fileName-                     (targetFileNoext, targetFileExt) = splitExtension $ targetFile-                     hsFile = targetFileNoext <.> "hs"--                 assert (targetFileExt `elem` [".lhs",".hs"]) $ return ()--                 createDirectoryIfMissing True targetDir--                 if needsCpp-                    then do-                      runSimplePreProcessor (ppCpp' defines bi lbi)-                                            file targetFile verbosity-                    else-                      copyFileVerbose verbosity file targetFile--                 when (targetFileExt == ".lhs") $ do-                     runSimplePreProcessor ppUnlit targetFile hsFile verbosity-                     removeFile targetFile--                 return hsFile-            needsCpp = EnableExtension CPP `elem` allExtensions bi-            defines | isVersion2 = []-                    | otherwise  = ["-D__HADDOCK__"]------------------------------------------------------------------------------------------------------- constributions to HaddockArgs--fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs-fromFlags env flags =-    mempty {-      argHideModules = (maybe mempty (All . not) $ flagToMaybe (haddockInternal flags), mempty),-      argLinkSource = if fromFlag (haddockHscolour flags)-                               then Flag ("src/%{MODULE/./-}.html"-                                         ,"src/%{MODULE/./-}.html#%{NAME}")-                               else NoFlag,-      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-    }--fromPackageDescription :: PackageDescription -> HaddockArgs-fromPackageDescription pkg_descr =-      mempty {-                argInterfaceFile = Flag $ haddockName pkg_descr,-                argPackageName = Flag $ packageId $ pkg_descr,-                argOutputDir = Dir $ "doc" </> "html" </> display (packageName pkg_descr),-                argPrologue = Flag $ if null desc then synopsis pkg_descr else desc,-                argTitle = Flag $ showPkg ++ subtitle-             }-      where-        desc = PD.description pkg_descr-        showPkg = display (packageId pkg_descr)-        subtitle | null (synopsis pkg_descr) = ""-                 | otherwise                 = ": " ++ synopsis pkg_descr--fromLibrary :: FilePath-            -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo-            -> IO HaddockArgs-fromLibrary tmp lbi lib clbi =-            do inFiles <- map snd `fmap` getLibSourceFiles lbi lib-               return $ mempty {-                            argHideModules = (mempty,otherModules $ bi),-                            argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi)-                                       -- Noooooooooo!!!!!111-                                       -- haddock stomps on our precious .hi-                                       -- and .o files. Workaround by telling-                                       -- haddock to write them elsewhere.-                                       ++ [ "-odir", tmp, "-hidir", tmp-                                          , "-stubdir", tmp ],-                            argTargets = inFiles-                          }-    where-      bi = libBuildInfo lib--fromExecutable :: FilePath-               -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo-               -> IO HaddockArgs-fromExecutable tmp lbi exe clbi =-            do inFiles <- map snd `fmap` getExeSourceFiles lbi exe-               return $ mempty {-                            argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi)-                                       -- Noooooooooo!!!!!111-                                       -- haddock stomps on our precious .hi-                                       -- and .o files. Workaround by telling-                                       -- haddock to write them elsewhere.-                                       ++ [ "-odir", tmp, "-hidir", tmp-                                          , "-stubdir", tmp ],-                            argOutputDir = Dir (exeName exe),-                            argTitle = Flag (exeName exe),-                            argTargets = inFiles-                          }-    where-      bi = buildInfo exe--getInterfaces :: Verbosity-                 -> LocalBuildInfo-                 -> Maybe String -- ^ template for html location-                 -> IO HaddockArgs-getInterfaces verbosity lbi location = do-    let htmlTemplate = fmap toPathTemplate $ location-    (packageFlags, warnings) <- haddockPackageFlags lbi htmlTemplate-    maybe (return ()) (warn verbosity) warnings-    return $ mempty {-                 argInterfaces = packageFlags-               }--getGhcLibDir :: Verbosity -> LocalBuildInfo-             -> Bool -- ^ are we using haddock-2.x ?-             -> IO HaddockArgs-getGhcLibDir verbosity lbi isVersion2-    | isVersion2 =-        do l <- ghcLibDir verbosity lbi-           return $ mempty { argGhcLibDir = Flag l }-    | otherwise  =-        return mempty---------------------------------------------------------------------------------------------------- | Call haddock with the specified arguments.-runHaddock :: Verbosity -> ConfiguredProgram -> HaddockArgs -> IO ()-runHaddock verbosity confHaddock args = do-  let haddockVersion = fromMaybe (error "unable to determine haddock version")-                       (programVersion confHaddock)-  renderArgs verbosity haddockVersion args $ \(flags,result)-> do--      rawSystemProgram verbosity confHaddock flags--      notice verbosity $ "Documentation created: " ++ result---renderArgs :: Verbosity-              -> Version-              -> HaddockArgs-              -> (([[Char]], FilePath) -> IO a)-              -> IO a-renderArgs verbosity version args k = do-  createDirectoryIfMissingVerbose verbosity True outputDir-  withTempFile outputDir "haddock-prolog.txt" $ \prologFileName h -> do-          do-             hPutStrLn h $ fromFlag $ argPrologue args-             hClose h-             let pflag = (:[]).("--prologue="++) $ prologFileName-             k $ (pflag ++ renderPureArgs version args, result)-    where-      isVersion2 = version >= Version [2,0] []-      outputDir = (unDir $ argOutputDir args)-      result = intercalate ", "-             . map (\o -> outputDir </>-                            case o of-                              Html -> "index.html"-                              Hoogle -> pkgstr <.> "txt")-             $ arg argOutput-            where-              pkgstr | isVersion2 = display $ packageName pkgid-                     | otherwise = display pkgid-              pkgid = arg argPackageName-      arg f = fromFlag $ f args--renderPureArgs :: Version -> HaddockArgs -> [[Char]]-renderPureArgs version args = concat-    [-     (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)-     . fromFlag . argInterfaceFile $ args,-     (\pkgName -> if isVersion2-                  then ["--optghc=-package-name", "--optghc=" ++ pkgName]-                  else ["--package=" ++ pkgName]) . display . fromFlag . argPackageName $ args,-     (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args,-     bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args,-     maybe [] (\(m,e) -> ["--source-module=" ++ m-                         ,"--source-entity=" ++ e]) . 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,-     bool id (const []) isVersion2 . map ("--optghc=" ++) . argGhcFlags $ args,-     maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and Nothing?-     argTargets $ args-    ]-    where-      renderInterfaces = map (\(i,mh) -> "--read-interface=" ++ maybe "" (++",") mh ++ i)-      bool a b c = if c then a else b-      isVersion2 = version >= Version [2,0] []-      isVersion2_5 = version >= Version [2,5] []-      verbosityFlag-       | isVersion2_5 = "--verbosity=1"-       | otherwise = "--verbose"---------------------------------------------------------------------------------------------------------------haddockPackageFlags :: LocalBuildInfo-                    -> Maybe PathTemplate-                    -> IO ([(FilePath,Maybe FilePath)], Maybe String)-haddockPackageFlags lbi htmlTemplate = do-  let allPkgs = installedPkgs lbi-      directDeps = map fst (externalPackageDeps lbi)-  transitiveDeps <- case dependencyClosure allPkgs directDeps of-    Left x    -> return x-    Right inf -> die $ "internal error when calculating transative "-                    ++ "package dependencies.\nDebug info: " ++ show inf-  interfaces <- sequence-    [ case interfaceAndHtmlPath ipkg of-        Nothing -> return (Left (packageId ipkg))-        Just (interface, html) -> do-          exists <- doesFileExist interface-          if exists-            then return (Right (interface, html))-            else return (Left (packageId ipkg))-    | ipkg <- PackageIndex.allPackages transitiveDeps ]--  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 display missing)-      flags = [ (interface, if null html then Nothing else Just html)-              | Right (interface, html) <- interfaces ]--  return (flags, if null missing then Nothing else Just warning)--  where-    interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, FilePath)-    interfaceAndHtmlPath pkg = do-      interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)-      html <- case htmlTemplate of-        Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)-        Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate)-      return (interface, html)--      where expandTemplateVars = fromPathTemplate . substPathTemplate env-            env = haddockTemplateEnv lbi (packageId pkg)--haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv-haddockTemplateEnv lbi pkg_id = (PrefixVar, prefix (installDirTemplates lbi))-                                : initialPathTemplateEnv pkg_id (compilerId (compiler lbi))---- ----------------------------------------------------------------------------- hscolour support--hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO ()-hscolour pkg_descr lbi suffixes flags = do-  -- we preprocess even if hscolour won't be found on the machine-  -- will this upset someone?-  initialBuildSteps distPref pkg_descr lbi verbosity-  hscolour' pkg_descr lbi suffixes flags- where-   verbosity  = fromFlag (hscolourVerbosity flags)-   distPref = fromFlag $ hscolourDistPref flags--hscolour' :: PackageDescription-          -> LocalBuildInfo-          -> [PPSuffixHandler]-          -> HscolourFlags-          -> IO ()-hscolour' pkg_descr lbi suffixes flags = do-    let distPref = fromFlag $ hscolourDistPref flags-    (hscolourProg, _, _) <--      requireProgramVersion-        verbosity hscolourProgram-        (orLaterVersion (Version [1,8] [])) (withPrograms lbi)--    setupMessage verbosity "Running hscolour for" (packageId pkg_descr)-    createDirectoryIfMissingVerbose verbosity True $ hscolourPref distPref pkg_descr--    let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes-    withComponentsLBI pkg_descr lbi $ \comp _ -> do-      pre comp-      case comp of-        CLib lib -> do-          let outputDir = hscolourPref distPref pkg_descr </> "src"-          runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib-        CExe exe | fromFlag (hscolourExecutables flags) -> do-          let outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src"-          runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe-        _ -> return ()-  where-    stylesheet = flagToMaybe (hscolourCSS flags)--    verbosity  = fromFlag (hscolourVerbosity flags)--    runHsColour prog outputDir moduleFiles = do-         createDirectoryIfMissingVerbose verbosity True outputDir--         case stylesheet of -- copy the CSS file-           Nothing | programVersion prog >= Just (Version [1,9] []) ->-                       rawSystemProgram verbosity prog-                          ["-print-css", "-o" ++ outputDir </> "hscolour.css"]-                   | otherwise -> return ()-           Just s -> copyFileVerbose verbosity s (outputDir </> "hscolour.css")--         flip mapM_ moduleFiles $ \(m, inFile) ->-             rawSystemProgram 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,-      hscolourVerbosity   = haddockVerbosity   flags,-      hscolourDistPref    = haddockDistPref    flags-    }-------------------------------------------------------------------------------------------------- TODO these should be moved elsewhere.--getLibSourceFiles :: LocalBuildInfo-                     -> Library-                     -> IO [(ModuleName.ModuleName, FilePath)]-getLibSourceFiles lbi lib = getSourceFiles searchpaths modules-  where-    bi               = libBuildInfo lib-    modules          = PD.exposedModules lib ++ otherModules bi-    searchpaths      = autogenModulesDir lbi : buildDir lbi : hsSourceDirs bi--getExeSourceFiles :: LocalBuildInfo-                     -> Executable-                     -> IO [(ModuleName.ModuleName, FilePath)]-getExeSourceFiles lbi exe = do-    moduleFiles <- getSourceFiles searchpaths modules-    srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe)-    return ((ModuleName.main, srcMainPath) : moduleFiles)-  where-    bi          = buildInfo exe-    modules     = otherModules bi-    searchpaths = autogenModulesDir lbi : exeBuildDir lbi exe : hsSourceDirs bi--getSourceFiles :: [FilePath]-                  -> [ModuleName.ModuleName]-                  -> IO [(ModuleName.ModuleName, FilePath)]-getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $-    findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m)-      >>= maybe (notFound m) (return . normalise)-  where-    notFound module_ = die $ "can't find source for module " ++ display module_---- | The directory where we put build results for an executable-exeBuildDir :: LocalBuildInfo -> Executable -> FilePath-exeBuildDir lbi exe = buildDir lbi </> exeName exe </> exeName exe ++ "-tmp"------------------------------------------------------------------------------------------------------ boilerplate monoid instance.-instance Monoid HaddockArgs where-    mempty = HaddockArgs {-                argInterfaceFile = mempty,-                argPackageName = mempty,-                argHideModules = mempty,-                argIgnoreExports = mempty,-                argLinkSource = mempty,-                argCssFile = mempty,-                argContents = mempty,-                argVerbose = mempty,-                argOutput = mempty,-                argInterfaces = mempty,-                argOutputDir = mempty,-                argTitle = mempty,-                argPrologue = mempty,-                argGhcFlags = mempty,-                argGhcLibDir = mempty,-                argTargets = mempty-             }-    mappend a b = HaddockArgs {-                argInterfaceFile = mult argInterfaceFile,-                argPackageName = mult argPackageName,-                argHideModules = mult argHideModules,-                argIgnoreExports = mult argIgnoreExports,-                argLinkSource = mult argLinkSource,-                argCssFile = mult argCssFile,-                argContents = mult argContents,-                argVerbose = mult argVerbose,-                argOutput = mult argOutput,-                argInterfaces = mult argInterfaces,-                argOutputDir = mult argOutputDir,-                argTitle = mult argTitle,-                argPrologue = mult argPrologue,-                argGhcFlags = mult argGhcFlags,-                argGhcLibDir = mult argGhcLibDir,-                argTargets = mult argTargets-             }-      where mult f = f a `mappend` f b--instance Monoid Directory where-    mempty = Dir "."-    mappend (Dir m) (Dir n) = Dir $ m </> n
− Distribution/Simple/Hpc.hs 
@@ -1,170 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Hpc--- Copyright   :  Thomas Tuegel 2011------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ 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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.Hpc-    ( enableCoverage-    , htmlDir-    , tixDir-    , tixFilePath-    , markupPackage-    , markupTest-    ) where--import Control.Monad ( when )-import Distribution.Compiler ( CompilerFlavor(..) )-import Distribution.ModuleName ( main )-import Distribution.PackageDescription-    ( BuildInfo(..)-    , Library(..)-    , PackageDescription(..)-    , TestSuite(..)-    , testModules-    )-import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )-import Distribution.Simple.Program ( hpcProgram, requireProgram )-import Distribution.Simple.Program.Hpc ( markup, union )-import Distribution.Simple.Utils ( notice )-import Distribution.Text-import Distribution.Verbosity ( Verbosity() )-import System.Directory ( createDirectoryIfMissing, doesFileExist )-import System.FilePath---- ---------------------------------------------------------------------------- Haskell Program Coverage---- | Conditionally enable Haskell Program Coverage by adding the necessary--- GHC options to a PackageDescription.------ TODO: do this differently in the build stage by constructing local build--- info, not by modifying the original PackageDescription.----enableCoverage :: Bool                  -- ^ Enable coverage?-               -> String                -- ^ \"dist/\" prefix-               -> PackageDescription-               -> PackageDescription-enableCoverage False _ x = x-enableCoverage True distPref p =-    p { library = fmap enableLibCoverage (library p)-      , testSuites = map enableTestCoverage (testSuites p)-      }-  where-    enableBICoverage name oldBI =-        let oldOptions = options oldBI-            oldGHCOpts = lookup GHC oldOptions-            newGHCOpts = case oldGHCOpts of-                             Just xs -> (GHC, hpcOpts ++ xs)-                             _ -> (GHC, hpcOpts)-            newOptions = (:) newGHCOpts $ filter ((== GHC) . fst) oldOptions-            hpcOpts = ["-fhpc", "-hpcdir", mixDir distPref name]-        in oldBI { options = newOptions }-    enableLibCoverage l =-        l { libBuildInfo = enableBICoverage (display $ package p)-                                            (libBuildInfo l)-          }-    enableTestCoverage t =-        t { testBuildInfo = enableBICoverage (testName t) (testBuildInfo t) }--hpcDir :: FilePath  -- ^ \"dist/\" prefix-       -> FilePath  -- ^ Directory containing component's HPC .mix files-hpcDir distPref = distPref </> "hpc"--mixDir :: FilePath  -- ^ \"dist/\" prefix-       -> FilePath  -- ^ Component name-       -> FilePath  -- ^ Directory containing test suite's .mix files-mixDir distPref name = hpcDir distPref </> "mix" </> name--tixDir :: FilePath  -- ^ \"dist/\" prefix-       -> FilePath  -- ^ Component name-       -> FilePath  -- ^ Directory containing test suite's .tix files-tixDir distPref name = hpcDir distPref </> "tix" </> name---- | Path to the .tix file containing a test suite's sum statistics.-tixFilePath :: FilePath     -- ^ \"dist/\" prefix-            -> FilePath     -- ^ Component name-            -> FilePath     -- ^ Path to test suite's .tix file-tixFilePath distPref name = tixDir distPref name </> name <.> "tix"--htmlDir :: FilePath     -- ^ \"dist/\" prefix-        -> FilePath     -- ^ Component name-        -> FilePath     -- ^ Path to test suite's HTML markup directory-htmlDir distPref name = hpcDir distPref </> "html" </> name---- | Generate the HTML markup for a test suite.-markupTest :: Verbosity-           -> LocalBuildInfo-           -> FilePath     -- ^ \"dist/\" prefix-           -> String       -- ^ Library name-           -> TestSuite-           -> IO ()-markupTest verbosity lbi distPref libName suite = do-    tixFileExists <- doesFileExist $ tixFilePath distPref $ testName suite-    when tixFileExists $ do-        (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi-        markup hpc verbosity (tixFilePath distPref $ testName suite)-                             (mixDir distPref libName)-                             (htmlDir distPref $ testName suite)-                             (testModules suite ++ [ main ])-        notice verbosity $ "Test coverage report written to "-                            ++ htmlDir distPref (testName suite)-                            </> "hpc_index" <.> "html"---- | Generate the HTML markup for all of a package's test suites.-markupPackage :: Verbosity-              -> LocalBuildInfo-              -> FilePath       -- ^ \"dist/\" prefix-              -> String         -- ^ Library name-              -> [TestSuite]-              -> IO ()-markupPackage verbosity lbi distPref libName suites = do-    let tixFiles = map (tixFilePath distPref . testName) suites-    tixFilesExist <- mapM doesFileExist tixFiles-    when (and tixFilesExist) $ do-        (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi-        let outFile = tixFilePath distPref libName-            mixDir' = mixDir distPref libName-            htmlDir' = htmlDir distPref libName-            excluded = concatMap testModules suites ++ [ main ]-        createDirectoryIfMissing True $ takeDirectory outFile-        union hpc verbosity tixFiles outFile excluded-        markup hpc verbosity outFile mixDir' htmlDir' excluded-        notice verbosity $ "Package coverage report written to "-                           ++ htmlDir' </> "hpc_index.html"
− Distribution/Simple/Hugs.hs 
@@ -1,632 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Hugs--- Copyright   :  Isaac Jones 2003-2006---                Duncan Coutts 2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module contains most of the NHC-specific code for configuring, building--- and installing packages.--{- Copyright (c) 2003-2005, Isaac Jones-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.Hugs (-    configure,-    getInstalledPackages,-    buildLib,-    buildExe,-    install,-    registerPackage,-  ) where--import Distribution.Package-         ( PackageName, PackageIdentifier(..), InstalledPackageId(..)-         , packageName )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo, emptyInstalledPackageInfo-         , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId-                                , sourcePackageId )-         , parseInstalledPackageInfo, showInstalledPackageInfo )-import Distribution.PackageDescription-         ( PackageDescription(..), BuildInfo(..), hcOptions, allExtensions-         , Executable(..), withExe, Library(..), withLib, libModules )-import Distribution.ModuleName (ModuleName)-import qualified Distribution.ModuleName as ModuleName-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..)-         , Compiler(..), Flag, languageToFlags, extensionsToFlags-         , PackageDB(..), PackageDBStack )-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)-import Distribution.Simple.Program-         ( Program(programFindVersion)-         , ProgramConfiguration, userMaybeSpecifyPath-         , requireProgram, requireProgramVersion-         , rawSystemProgramConf, programPath-         , ffihugsProgram, hugsProgram )-import Distribution.Version-         ( Version(..), orLaterVersion )-import Distribution.Simple.PreProcess   ( ppCpp, runSimplePreProcessor )-import Distribution.Simple.PreProcess.Unlit-                                ( unlit )-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-         , InstallDirs(..), absoluteInstallDirs )-import Distribution.Simple.BuildPaths-                                ( autogenModuleName, autogenModulesDir,-                                  dllExtension )-import Distribution.Simple.Setup-         ( CopyDest(..) )-import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose-         , installOrdinaryFiles, setFileExecutable-         , withUTF8FileContents, writeFileAtomic, writeUTF8File-         , copyFileVerbose, findFile, findFileWithExtension, findModuleFiles-         , rawSystemStdInOut-         , die, info, notice )-import Language.Haskell.Extension-         ( Language(Haskell98), Extension(..), KnownExtension(..) )-import System.FilePath          ( (</>), takeExtension, (<.>),-                                  searchPathSeparator, normalise, takeDirectory )-import Distribution.System-         ( OS(..), buildOS )-import Distribution.Text-         ( display, simpleParse )-import Distribution.ParseUtils-         ( ParseResult(..) )-import Distribution.Verbosity--import Data.Char                ( isSpace )-import Data.Maybe               ( mapMaybe, catMaybes )-import Data.Monoid              ( Monoid(..) )-import Control.Monad            ( unless, when, filterM )-import Data.List                ( nub, sort, isSuffixOf )-import System.Directory-         ( doesFileExist, doesDirectoryExist, getDirectoryContents-         , removeDirectoryRecursive, getHomeDirectory )-import System.Exit-         ( ExitCode(ExitSuccess) )-import Distribution.Compat.Exception---- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)-configure verbosity hcPath _hcPkgPath conf = do--  (_ffihugsProg, conf') <- requireProgram verbosity ffihugsProgram-                            (userMaybeSpecifyPath "ffihugs" hcPath conf)-  (_hugsProg, version, conf'')-                        <- requireProgramVersion verbosity hugsProgram'-                            (orLaterVersion (Version [2006] [])) conf'--  let comp = Compiler {-        compilerId             = CompilerId Hugs version,-        compilerLanguages      = hugsLanguages,-        compilerExtensions     = hugsLanguageExtensions-      }-  return (comp, conf'')--  where-    hugsProgram' = hugsProgram { programFindVersion = getVersion }--getVersion :: Verbosity -> FilePath -> IO (Maybe Version)-getVersion verbosity hugsPath = do-  (output, _err, exit) <- rawSystemStdInOut verbosity hugsPath []-                              (Just (":quit", False)) False-  if exit == ExitSuccess-    then return $! findVersion output-    else return Nothing--  where-    findVersion output = do-      (monthStr, yearStr) <- selectWords output-      year  <- convertYear yearStr-      month <- convertMonth monthStr-      return (Version [year, month] [])--    selectWords output =-      case [ (month, year)-           | [_,_,"Version:", month, year,_] <- map words (lines output) ] of-        [(month, year)] -> Just (month, year)-        _               -> Nothing-    convertYear year = case reads year of-      [(y, [])] | y >= 1999 && y < 2020 -> Just y-      _                                 -> Nothing-    convertMonth month = lookup month (zip months [1..])-    months = [ "January", "February", "March", "April", "May", "June", "July"-             , "August", "September", "October", "November", "December" ]--hugsLanguages :: [(Language, Flag)]-hugsLanguages = [(Haskell98, "")] --default is 98 mode---- | The flags for the supported extensions-hugsLanguageExtensions :: [(Extension, Flag)]-hugsLanguageExtensions =-    let doFlag (f, (enable, disable)) = [(EnableExtension  f, enable),-                                         (DisableExtension f, disable)]-        alwaysOn = ("", ""{- wrong -})-        ext98 = ("-98", ""{- wrong -})-    in concatMap doFlag-    [(OverlappingInstances       , ("+o",  "-o"))-    ,(IncoherentInstances        , ("+oO", "-O"))-    ,(HereDocuments              , ("+H",  "-H"))-    ,(TypeSynonymInstances       , ext98)-    ,(RecursiveDo                , ext98)-    ,(ParallelListComp           , ext98)-    ,(MultiParamTypeClasses      , ext98)-    ,(FunctionalDependencies     , ext98)-    ,(Rank2Types                 , ext98)-    ,(PolymorphicComponents      , ext98)-    ,(ExistentialQuantification  , ext98)-    ,(ScopedTypeVariables        , ext98)-    ,(ImplicitParams             , ext98)-    ,(ExtensibleRecords          , ext98)-    ,(RestrictedTypeSynonyms     , ext98)-    ,(FlexibleContexts           , ext98)-    ,(FlexibleInstances          , ext98)-    ,(ForeignFunctionInterface   , alwaysOn)-    ,(EmptyDataDecls             , alwaysOn)-    ,(CPP                        , alwaysOn)-    ]--getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration-                     -> IO PackageIndex-getInstalledPackages verbosity packagedbs conf = do-  homedir       <- getHomeDirectory-  (hugsProg, _) <- requireProgram verbosity hugsProgram conf-  let hugsbindir = takeDirectory (programPath hugsProg)-      hugslibdir = takeDirectory hugsbindir </> "lib" </> "hugs"-      dbdirs = nub (concatMap (packageDbPaths homedir hugslibdir) packagedbs)-  indexes  <- mapM getIndividualDBPackages dbdirs-  return $! mconcat indexes--  where-    getIndividualDBPackages :: FilePath -> IO PackageIndex-    getIndividualDBPackages dbdir = do-      pkgdirs <- getPackageDbDirs dbdir-      pkgs    <- sequence [ getInstalledPackage pkgname pkgdir-                          | (pkgname, pkgdir) <- pkgdirs ]-      let pkgs' = map setInstalledPackageId (catMaybes pkgs)-      return (PackageIndex.fromList pkgs')--packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]-packageDbPaths home hugslibdir db = case db of-  GlobalPackageDB        -> [ hugslibdir </> "packages"-                            , "/usr/local/lib/hugs/packages" ]-  UserPackageDB          -> [ home </> "lib/hugs/packages" ]-  SpecificPackageDB path -> [ path ]--getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)]-getPackageDbDirs dbdir = do-  dbexists <- doesDirectoryExist dbdir-  if not dbexists-    then return []-    else do-      entries  <- getDirectoryContents dbdir-      pkgdirs  <- sequence-        [ do pkgdirExists <- doesDirectoryExist pkgdir-             return (pkgname, pkgdir, pkgdirExists)-        | (entry, Just pkgname) <- [ (entry, simpleParse entry)-                                   | entry <- entries ]-        , let pkgdir = dbdir </> entry ]-      return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ]--getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo)-getInstalledPackage pkgname pkgdir = do-  let pkgconfFile = pkgdir </> "package.conf"-  pkgconfExists <- doesFileExist pkgconfFile--  let pathsModule = pkgdir </> ("Paths_" ++ display pkgname)  <.> "hs"-  pathsModuleExists <- doesFileExist pathsModule--  case () of-    _ | pkgconfExists     -> getFullInstalledPackageInfo pkgname pkgconfFile-      | pathsModuleExists -> getPhonyInstalledPackageInfo pkgname pathsModule-      | otherwise         -> return Nothing--getFullInstalledPackageInfo :: PackageName -> FilePath-                            -> IO (Maybe InstalledPackageInfo)-getFullInstalledPackageInfo pkgname pkgconfFile =-  withUTF8FileContents pkgconfFile $ \contents ->-    case parseInstalledPackageInfo contents of-      ParseOk _ pkginfo | packageName pkginfo == pkgname-                        -> return (Just pkginfo)-      _                 -> return Nothing---- | This is a backup option for existing versions of Hugs which do not supply--- proper installed package info files for the bundled libs. Instead we look--- for the Paths_pkgname.hs file and extract the package version from that.--- We don't know any other details for such packages, in particular we pretend--- that they have no dependencies.----getPhonyInstalledPackageInfo :: PackageName -> FilePath-                             -> IO (Maybe InstalledPackageInfo)-getPhonyInstalledPackageInfo pkgname pathsModule = do-  content <- readFile pathsModule-  case extractVersion content of-    Nothing      -> return Nothing-    Just version -> return (Just pkginfo)-      where-        pkgid   = PackageIdentifier pkgname version-        pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid }-  where-    -- search through the Paths_pkgname.hs file, looking for a line like:-    ---    -- > version = Version {versionBranch = [2,0], versionTags = []}-    ---    -- and parse it using 'Read'. Yes we are that evil.-    ---    extractVersion content =-      case [ version-           | ("version":"=":rest) <- map words (lines content)-           , (version, []) <- reads (concat rest) ] of-        [version] -> Just version-        _         -> Nothing---- Older installed package info files did not have the installedPackageId--- field, so if it is missing then we fill it as the source package ID.-setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo-setInstalledPackageId pkginfo@InstalledPackageInfo {-                        installedPackageId = InstalledPackageId "",-                        sourcePackageId    = pkgid-                      }-                    = pkginfo {-                        --TODO use a proper named function for the conversion-                        -- from source package id to installed package id-                        installedPackageId = InstalledPackageId (display pkgid)-                      }-setInstalledPackageId pkginfo = pkginfo---- -------------------------------------------------------------------------------- Building---- |Building a package for Hugs.-buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity pkg_descr lbi lib _clbi = do-    let pref = scratchDir lbi-    createDirectoryIfMissingVerbose verbosity True pref-    copyFileVerbose verbosity (autogenModulesDir lbi </> paths_modulename)-                              (pref </> paths_modulename)-    compileBuildInfo verbosity pref [] (libModules lib) (libBuildInfo lib) lbi-  where-    paths_modulename = ModuleName.toFilePath (autogenModuleName pkg_descr)-                         <.> ".hs"-    --TODO: switch to using autogenModulesDir as a search dir, rather than-    --      always copying the file over.---- |Building an executable for Hugs.-buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity pkg_descr lbi-  exe@Executable {modulePath=mainPath, buildInfo=bi} _clbi = do-    let pref = scratchDir lbi-    createDirectoryIfMissingVerbose verbosity True pref-    -    let destDir = pref </> "programs"-    let exeMods = otherModules bi-    srcMainFile <- findFile (hsSourceDirs bi) mainPath-    let exeDir = destDir </> exeName exe-    let destMainFile = exeDir </> hugsMainFilename exe-    copyModule verbosity (EnableExtension CPP `elem` allExtensions bi) bi lbi srcMainFile destMainFile-    let destPathsFile = exeDir </> paths_modulename-    copyFileVerbose verbosity (autogenModulesDir lbi </> paths_modulename)-                              destPathsFile-    compileBuildInfo verbosity exeDir -      (maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)) exeMods bi lbi-    compileFiles verbosity bi lbi exeDir [destMainFile, destPathsFile]--  where-    paths_modulename = ModuleName.toFilePath (autogenModuleName pkg_descr)-                         <.> ".hs"--compileBuildInfo :: Verbosity-                 -> FilePath -- ^output directory-                 -> [FilePath] -- ^library source dirs, if building exes-                 -> [ModuleName] -- ^Modules-                 -> BuildInfo-                 -> LocalBuildInfo-                 -> IO ()---TODO: should not be using mLibSrcDirs at all-compileBuildInfo verbosity destDir mLibSrcDirs mods bi lbi = do-    -- Pass 1: copy or cpp files from build directory to scratch directory-    let useCpp = EnableExtension CPP `elem` allExtensions bi-    let srcDir = buildDir lbi-        srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs-    info verbosity $ "Source directories: " ++ show srcDirs-    flip mapM_ mods $ \ m -> do-        fs <- findFileWithExtension suffixes srcDirs (ModuleName.toFilePath m)-        case fs of-          Nothing ->-            die ("can't find source for module " ++ display m)-          Just srcFile -> do-            let ext = takeExtension srcFile-            copyModule verbosity useCpp bi lbi srcFile-                (destDir </> ModuleName.toFilePath m <.> ext)-    -- Pass 2: compile foreign stubs in scratch directory-    stubsFileLists <- fmap catMaybes $ sequence-      [ findFileWithExtension suffixes [destDir] (ModuleName.toFilePath modu)-      | modu <- mods]-    compileFiles verbosity bi lbi destDir stubsFileLists--suffixes :: [String]-suffixes = ["hs", "lhs"]---- Copy or cpp a file from the source directory to the build directory.-copyModule :: Verbosity -> Bool -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO ()-copyModule verbosity cppAll bi lbi srcFile destFile = do-    createDirectoryIfMissingVerbose verbosity True (takeDirectory destFile)-    (exts, opts, _) <- getOptionsFromSource srcFile-    let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ]-    if cppAll || EnableExtension CPP `elem` exts || "-cpp" `elem` ghcOpts then do-        runSimplePreProcessor (ppCpp bi lbi) srcFile destFile verbosity-        return ()-      else-        copyFileVerbose verbosity srcFile destFile--compileFiles :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> [FilePath] -> IO ()-compileFiles verbosity bi lbi modDir fileList = do-    ffiFileList <- filterM testFFI fileList-    unless (null ffiFileList) $ do-        notice verbosity "Compiling FFI stubs"-        mapM_ (compileFFI verbosity bi lbi modDir) ffiFileList---- Only compile FFI stubs for a file if it contains some FFI stuff-testFFI :: FilePath -> IO Bool-testFFI file =-  withHaskellFile file $ \inp ->-    return $! "foreign" `elem` symbols (stripComments False inp)--compileFFI :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO ()-compileFFI verbosity bi lbi modDir file = do-    (_, opts, file_incs) <- getOptionsFromSource file-    let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ]-    let pkg_incs = ["\"" ++ inc ++ "\"" | inc <- includes bi]-    let incs = nub (sort (file_incs ++ includeOpts ghcOpts ++ pkg_incs))-    let pathFlag = "-P" ++ modDir ++ [searchPathSeparator]-    let hugsArgs = "-98" : pathFlag : map ("-i" ++) incs-    cfiles <- getCFiles file-    let cArgs =-            ["-I" ++ dir | dir <- includeDirs bi] ++-            ccOptions bi ++-            cfiles ++-            ["-L" ++ dir | dir <- extraLibDirs bi] ++-            ldOptions bi ++-            ["-l" ++ lib | lib <- extraLibs bi] ++-            concat [["-framework", f] | f <- frameworks bi]-    rawSystemProgramConf verbosity ffihugsProgram (withPrograms lbi)-      (hugsArgs ++ file : cArgs)--includeOpts :: [String] -> [String]-includeOpts [] = []-includeOpts ("-#include" : arg : opts) = arg : includeOpts opts-includeOpts (_ : opts) = includeOpts opts---- get C file names from CFILES pragmas throughout the source file-getCFiles :: FilePath -> IO [String]-getCFiles file =-  withHaskellFile file $ \inp ->-    let cfiles =-          [ normalise cfile-          | "{-#" : "CFILES" : rest <- map words-                                     $ lines-                                     $ stripComments True inp-          , last rest == "#-}"-          , cfile <- init rest]-     in seq (length cfiles) (return cfiles)---- List of terminal symbols in a source file.-symbols :: String -> [String]-symbols cs = case lex cs of-    (sym, cs'):_ | not (null sym) -> sym : symbols cs'-    _ -> []---- Get the non-literate source of a Haskell module.-withHaskellFile :: FilePath -> (String -> IO a) -> IO a-withHaskellFile file action =-    withUTF8FileContents file $ \text ->-        if ".lhs" `isSuffixOf` file-          then either action die (unlit file text)-          else action text---- --------------------------------------------------------------- * options in source files--- ---------------------------------------------------------------- |Read the initial part of a source file, before any Haskell code,--- and return the contents of any LANGUAGE, OPTIONS and INCLUDE pragmas.-getOptionsFromSource-    :: FilePath-    -> IO ([Extension],                 -- LANGUAGE pragma, if any-           [(CompilerFlavor,[String])], -- OPTIONS_FOO pragmas-           [String]                     -- INCLUDE pragmas-          )-getOptionsFromSource file =-    withHaskellFile file $-        (return $!)-      . foldr appendOptions ([],[],[]) . map getOptions-      . takeWhileJust . map getPragma-      . filter textLine . map (dropWhile isSpace) . lines-      . stripComments True--  where textLine [] = False-        textLine ('#':_) = False-        textLine _ = True--        getPragma :: String -> Maybe [String]-        getPragma line = case words line of-            ("{-#" : rest) | last rest == "#-}" -> Just (init rest)-            _ -> Nothing--        getOptions ("OPTIONS":opts) = ([], [(GHC, opts)], [])-        getOptions ("OPTIONS_GHC":opts) = ([], [(GHC, opts)], [])-        getOptions ("OPTIONS_NHC98":opts) = ([], [(NHC, opts)], [])-        getOptions ("OPTIONS_HUGS":opts) = ([], [(Hugs, opts)], [])-        getOptions ("LANGUAGE":ws) = (mapMaybe readExtension ws, [], [])-          where readExtension :: String -> Maybe Extension-                readExtension w = case reads w of-                    [(ext, "")] -> Just ext-                    [(ext, ",")] -> Just ext-                    _ -> Nothing-        getOptions ("INCLUDE":ws) = ([], [], ws)-        getOptions _ = ([], [], [])--        appendOptions (exts, opts, incs) (exts', opts', incs')-          = (exts++exts', opts++opts', incs++incs')---- takeWhileJust f = map fromJust . takeWhile isJust-takeWhileJust :: [Maybe a] -> [a]-takeWhileJust (Just x:xs) = x : takeWhileJust xs-takeWhileJust _ = []---- |Strip comments from Haskell source.-stripComments-    :: Bool     -- ^ preserve pragmas?-    -> String   -- ^ input source text-    -> String-stripComments keepPragmas = stripCommentsLevel 0-  where stripCommentsLevel :: Int -> String -> String-        stripCommentsLevel 0 ('"':cs) = '"':copyString cs-        stripCommentsLevel 0 ('-':'-':cs) =     -- FIX: symbols like -->-            stripCommentsLevel 0 (dropWhile (/= '\n') cs)-        stripCommentsLevel 0 ('{':'-':'#':cs)-          | keepPragmas = '{' : '-' : '#' : copyPragma cs-        stripCommentsLevel n ('{':'-':cs) = stripCommentsLevel (n+1) cs-        stripCommentsLevel 0 (c:cs) = c : stripCommentsLevel 0 cs-        stripCommentsLevel n ('-':'}':cs) = stripCommentsLevel (n-1) cs-        stripCommentsLevel n (_:cs) = stripCommentsLevel n cs-        stripCommentsLevel _ [] = []--        copyString ('\\':c:cs) = '\\' : c : copyString cs-        copyString ('"':cs) = '"' : stripCommentsLevel 0 cs-        copyString (c:cs) = c : copyString cs-        copyString [] = []--        copyPragma ('#':'-':'}':cs) = '#' : '-' : '}' : stripCommentsLevel 0 cs-        copyPragma (c:cs) = c : copyPragma cs-        copyPragma [] = []---- -------------------------------------------------------------------------------- |Install for Hugs.--- For install, copy-prefix = prefix, but for copy they're different.--- The library goes in \<copy-prefix>\/lib\/hugs\/packages\/\<pkgname>--- (i.e. \<prefix>\/lib\/hugs\/packages\/\<pkgname> on the target system).--- Each executable goes in \<copy-prefix>\/lib\/hugs\/programs\/\<exename>--- (i.e. \<prefix>\/lib\/hugs\/programs\/\<exename> on the target system)--- with a script \<copy-prefix>\/bin\/\<exename> pointing at--- \<prefix>\/lib\/hugs\/programs\/\<exename>.-install-    :: Verbosity -- ^verbosity-    -> LocalBuildInfo-    -> FilePath  -- ^Library install location-    -> FilePath  -- ^Program install location-    -> FilePath  -- ^Executable install location-    -> FilePath  -- ^Program location on target system-    -> FilePath  -- ^Build location-    -> (FilePath,FilePath)  -- ^Executable (prefix,suffix)-    -> PackageDescription-    -> IO ()---FIXME: this script should be generated at build time, just installed at this stage-install verbosity lbi libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do-    removeDirectoryRecursive libDir `catchIO` \_ -> return ()-    withLib pkg_descr $ \ lib ->-      findModuleFiles [buildPref] hugsInstallSuffixes (libModules lib)-        >>= installOrdinaryFiles verbosity libDir-    let buildProgDir = buildPref </> "programs"-    when (any (buildable . buildInfo) (executables pkg_descr)) $-        createDirectoryIfMissingVerbose verbosity True binDir-    withExe pkg_descr $ \ exe -> do-        let bi = buildInfo exe-        let theBuildDir = buildProgDir </> exeName exe-        let installDir = installProgDir </> exeName exe-        let targetDir = targetProgDir </> exeName exe-        removeDirectoryRecursive installDir `catchIO` \_ -> return ()-        findModuleFiles [theBuildDir] hugsInstallSuffixes-                        (ModuleName.main : autogenModuleName pkg_descr-                                         : otherModules (buildInfo exe))-          >>= installOrdinaryFiles verbosity installDir-        let targetName = "\"" ++ (targetDir </> hugsMainFilename exe) ++ "\""-        let hugsOptions = hcOptions Hugs (buildInfo exe)-                       ++ languageToFlags (compiler lbi) (defaultLanguage bi)-                       ++ extensionsToFlags (compiler lbi) (allExtensions bi)-            --TODO: also need to consider options, extensions etc of deps-            --      see ticket #43-        let baseExeFile = progprefix ++ (exeName exe) ++ progsuffix-        let exeFile = case buildOS of-                          Windows -> binDir </> baseExeFile <.> ".bat"-                          _       -> binDir </> baseExeFile-        let script = case buildOS of-                         Windows ->-                             let args = hugsOptions ++ [targetName, "%*"]-                             in unlines ["@echo off",-                                         unwords ("runhugs" : args)]-                         _ ->-                             let args = hugsOptions ++ [targetName, "\"$@\""]-                             in unlines ["#! /bin/sh",-                                         unwords ("runhugs" : args)]-        writeFileAtomic exeFile script-        setFileExecutable exeFile--hugsInstallSuffixes :: [String]-hugsInstallSuffixes = [".hs", ".lhs", dllExtension]---- |Filename used by Hugs for the main module of an executable.--- This is a simple filename, so that Hugs will look for any auxiliary--- modules it uses relative to the directory it's in.-hugsMainFilename :: Executable -> FilePath-hugsMainFilename exe = "Main" <.> ext-  where ext = takeExtension (modulePath exe)---- -------------------------------------------------------------------------------- Registering--registerPackage-  :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool-  -> PackageDBStack-  -> IO ()-registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do-  --TODO: prefer to have it based on the packageDbs, but how do we know-  -- the package subdir based on the name? the user can set crazy libsubdir-  let installDirs = absoluteInstallDirs pkg lbi NoCopyDest-      pkgdir  | inplace   = buildDir lbi-              | otherwise = libdir installDirs-  createDirectoryIfMissingVerbose verbosity True pkgdir-  writeUTF8File (pkgdir </> "package.conf")-                (showInstalledPackageInfo installedPkgInfo)
− Distribution/Simple/Install.hs 
@@ -1,214 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Install--- Copyright   :  Isaac Jones 2003-2004------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This is the entry point into installing a built package. Performs the--- \"@.\/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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.Install (-        install,-  ) where--import Distribution.PackageDescription (-        PackageDescription(..), BuildInfo(..), Library(..),-        hasLibs, withLib, hasExes, withExe )-import Distribution.Package (Package(..))-import Distribution.Simple.LocalBuildInfo (-        LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs,-        substPathTemplate)-import Distribution.Simple.BuildPaths (haddockName, haddockPref)-import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, installDirectoryContents-         , installOrdinaryFile, die, info, notice, matchDirFileGlob )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), compilerFlavor )-import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..), fromFlag)--import qualified Distribution.Simple.GHC  as GHC-import qualified Distribution.Simple.NHC  as NHC-import qualified Distribution.Simple.JHC  as JHC-import qualified Distribution.Simple.LHC  as LHC-import qualified Distribution.Simple.Hugs as Hugs-import qualified Distribution.Simple.UHC  as UHC--import Control.Monad (when, unless)-import System.Directory-         ( doesDirectoryExist, doesFileExist )-import System.FilePath-         ( takeFileName, takeDirectory, (</>), isAbsolute )--import Distribution.Verbosity-import Distribution.Text-         ( display )---- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\"--- actions.  Move files into place based on the prefix argument.  FIX:--- nhc isn't implemented yet.--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-  let distPref  = fromFlag (copyDistPref flags)-      verbosity = fromFlag (copyVerbosity flags)-      copydest  = fromFlag (copyDest flags)-      installDirs@(InstallDirs {-         bindir     = binPref,-         libdir     = libPref,---         dynlibdir  = dynlibPref, --see TODO below-         datadir    = dataPref,-         progdir    = progPref,-         docdir     = docPref,-         htmldir    = htmlPref,-         haddockdir = interfacePref,-         includedir = incPref})-             = absoluteInstallDirs pkg_descr lbi copydest--      --TODO: decide if we need the user to be able to control the libdir-      -- for shared libs independently of the one for static libs. If so-      -- it should also have a flag in the command line UI-      -- For the moment use dynlibdir = libdir-      dynlibPref = libPref-      progPrefixPref = substPathTemplate (packageId pkg_descr) lbi (progPrefix lbi)-      progSuffixPref = substPathTemplate (packageId pkg_descr) lbi (progSuffix lbi)--  docExists <- doesDirectoryExist $ haddockPref distPref pkg_descr-  info verbosity ("directory " ++ haddockPref distPref pkg_descr ++-                  " does exist: " ++ show docExists)--  installDataFiles verbosity pkg_descr dataPref--  when docExists $ do-      createDirectoryIfMissingVerbose verbosity True htmlPref-      installDirectoryContents verbosity-          (haddockPref 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 distPref pkg_descr-                                                   </> haddockName pkg_descr-          haddockInterfaceFileDest = interfacePref </> haddockName pkg_descr-      -- We only generate the haddock interface file for libs, So if the-      -- package consists only of executables there will not be one:-      exists <- doesFileExist haddockInterfaceFileSrc-      when exists $ do-        createDirectoryIfMissingVerbose verbosity True interfacePref-        installOrdinaryFile verbosity haddockInterfaceFileSrc-                                      haddockInterfaceFileDest--  let lfile = licenseFile pkg_descr-  unless (null lfile) $ do-    createDirectoryIfMissingVerbose verbosity True docPref-    installOrdinaryFile verbosity lfile (docPref </> takeFileName lfile)--  let buildPref = buildDir lbi-  when (hasLibs pkg_descr) $-    notice verbosity ("Installing library in " ++ libPref)-  when (hasExes pkg_descr) $-    notice verbosity ("Installing executable(s) in " ++ binPref)--  -- install include files for all compilers - they may be needed to compile-  -- haskell files (using the CPP extension)-  when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref--  case compilerFlavor (compiler lbi) of-     GHC  -> do withLib pkg_descr $-                  GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr-                withExe pkg_descr $-                  GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr-     LHC  -> do withLib pkg_descr $-                  LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr-                withExe pkg_descr $-                  LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr-     JHC  -> do withLib pkg_descr $-                  JHC.installLib verbosity libPref buildPref pkg_descr-                withExe pkg_descr $-                  JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr-     Hugs -> do-       let targetProgPref = progdir (absoluteInstallDirs pkg_descr lbi NoCopyDest)-       let scratchPref = scratchDir lbi-       Hugs.install verbosity lbi libPref progPref binPref targetProgPref scratchPref (progPrefixPref, progSuffixPref) pkg_descr-     NHC  -> do withLib pkg_descr $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr)-                withExe pkg_descr $ NHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref)-     UHC  -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr-     _    -> die $ "installing with "-                ++ display (compilerFlavor (compiler lbi))-                ++ " is not implemented"-  return ()-  -- register step should be performed by caller.---- | Install the files listed in data-files----installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO ()-installDataFiles verbosity pkg_descr destDataDir =-  flip mapM_ (dataFiles pkg_descr) $ \ file -> do-    let srcDataDir = dataDir pkg_descr-    files <- matchDirFileGlob srcDataDir file-    let dir = takeDirectory file-    createDirectoryIfMissingVerbose verbosity True (destDataDir </> dir)-    sequence_ [ installOrdinaryFile verbosity (srcDataDir  </> file')-                                              (destDataDir </> file')-              | file' <- files ]---- | Install the files listed in install-includes----installIncludeFiles :: Verbosity -> PackageDescription -> FilePath -> IO ()-installIncludeFiles verbosity-  PackageDescription { library = Just lib } destIncludeDir = do--  incs <- mapM (findInc relincdirs) (installIncludes lbi)-  sequence_-    [ do createDirectoryIfMissingVerbose verbosity True destDir-         installOrdinaryFile verbosity srcFile destFile-    | (relFile, srcFile) <- incs-    , let destFile = destIncludeDir </> relFile-          destDir  = takeDirectory destFile ]-  where-   relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)-   lbi = libBuildInfo lib--   findInc []         file = die ("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-installIncludeFiles _ _ _ = die "installIncludeFiles: Can't happen?"
− Distribution/Simple/InstallDirs.hs 
@@ -1,604 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp -fffi #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.InstallDirs--- Copyright   :  Isaac Jones 2003-2004------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This manages everything to do with where files get installed (though does--- not get involved with actually doing any installation). It provides an--- 'InstallDirs' type which is a set of directories for where to install--- things. It also handles the fact that we use templates in these install--- dirs. For example most install dirs are relative to some @$prefix@ and by--- changing the prefix all other dirs still end up changed appropriately. So it--- provides a 'PathTemplate' type and functions for substituting for these--- templates.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.InstallDirs (-        InstallDirs(..),-        InstallDirTemplates,-        defaultInstallDirs,-        combineInstallDirs,-        absoluteInstallDirs,-        CopyDest(..),-        prefixRelativeInstallDirs,-        substituteInstallDirTemplates,--        PathTemplate,-        PathTemplateVariable(..),-        PathTemplateEnv,-        toPathTemplate,-        fromPathTemplate,-        substPathTemplate,-        initialPathTemplateEnv,-        platformTemplateEnv,-        compilerTemplateEnv,-        packageTemplateEnv,-        installDirsTemplateEnv,-  ) where---import Data.List (isPrefixOf)-import Data.Maybe (fromMaybe)-import Data.Monoid (Monoid(..))-import System.Directory (getAppUserDataDirectory)-import System.FilePath ((</>), isPathSeparator, pathSeparator)-#if __HUGS__ || __GLASGOW_HASKELL__ > 606-import System.FilePath (dropDrive)-#endif--import Distribution.Package-         ( PackageIdentifier, packageName, packageVersion )-import Distribution.System-         ( OS(..), buildOS, Platform(..), buildPlatform )-import Distribution.Compiler-         ( CompilerId, CompilerFlavor(..) )-import Distribution.Text-         ( display )--#if mingw32_HOST_OS || mingw32_TARGET_OS-import Foreign-import Foreign.C-#endif---- ------------------------------------------------------------------------------ Instalation 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 direcotries. This is particularly the case on--- unix style systems.----data InstallDirs dir = InstallDirs {-        prefix       :: dir,-        bindir       :: dir,-        libdir       :: dir,-        libsubdir    :: dir,-        dynlibdir    :: dir,-        libexecdir   :: dir,-        progdir      :: dir,-        includedir   :: dir,-        datadir      :: dir,-        datasubdir   :: dir,-        docdir       :: dir,-        mandir       :: dir,-        htmldir      :: dir,-        haddockdir   :: dir-    } deriving (Read, Show)--instance Functor InstallDirs where-  fmap f dirs = InstallDirs {-    prefix       = f (prefix dirs),-    bindir       = f (bindir dirs),-    libdir       = f (libdir dirs),-    libsubdir    = f (libsubdir dirs),-    dynlibdir    = f (dynlibdir dirs),-    libexecdir   = f (libexecdir dirs),-    progdir      = f (progdir dirs),-    includedir   = f (includedir dirs),-    datadir      = f (datadir dirs),-    datasubdir   = f (datasubdir dirs),-    docdir       = f (docdir dirs),-    mandir       = f (mandir dirs),-    htmldir      = f (htmldir dirs),-    haddockdir   = f (haddockdir dirs)-  }--instance Monoid dir => Monoid (InstallDirs dir) where-  mempty = InstallDirs {-      prefix       = mempty,-      bindir       = mempty,-      libdir       = mempty,-      libsubdir    = mempty,-      dynlibdir    = mempty,-      libexecdir   = mempty,-      progdir      = mempty,-      includedir   = mempty,-      datadir      = mempty,-      datasubdir   = mempty,-      docdir       = mempty,-      mandir       = mempty,-      htmldir      = mempty,-      haddockdir   = mempty-  }-  mappend = combineInstallDirs mappend--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,-    libexecdir   = libexecdir a `combine` libexecdir b,-    progdir      = progdir a    `combine` progdir 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-  }--appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a-appendSubdirs append dirs = dirs {-    libdir     = libdir dirs `append` libsubdir dirs,-    datadir    = datadir dirs `append` datasubdir dirs,-    libsubdir  = error "internal error InstallDirs.libsubdir",-    datasubdir = error "internal error InstallDirs.datasubdir"-  }---- | The installation directories in terms of 'PathTemplate's that contain--- variables.------ The defaults for most of the directories are relative to each other, in--- particular they are all relative to a single prefix. This makes it--- convenient for the user to override the default installation directory--- by only having to specify --prefix=... rather than overriding each--- individually. This is done by allowing $-style variables in the dirs.--- These are expanded by textual substituion (see 'substPathTemplate').------ A few of these installation directories are split into two components, the--- dir and subdir. The full installation path is formed by combining the two--- together with @\/@. The reason for this is compatibility with other unix--- build systems which also support @--libdir@ and @--datadir@. We would like--- users to be able to configure @--libdir=\/usr\/lib64@ for example but--- because by default we want to support installing multiple versions of--- packages and building the same package for multiple compilers we append the--- libsubdir to get: @\/usr\/lib64\/$pkgid\/$compiler@.------ An additional complication is the need to support relocatable packages on--- systems which support such things, like Windows.----type InstallDirTemplates = InstallDirs PathTemplate---- ------------------------------------------------------------------------------ Default installation directories--defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates-defaultInstallDirs comp userInstall _hasLibs = do-  installPrefix <--      if userInstall-      then getAppUserDataDirectory "cabal"-      else case buildOS of-           Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir-                         return (windowsProgramFilesDir </> "Haskell")-           _       -> return "/usr/local"-  installLibDir <--      case buildOS of-      Windows -> return "$prefix"-      _       -> case comp of-                 LHC | userInstall -> getAppUserDataDirectory "lhc"-                 _                 -> return ("$prefix" </> "lib")-  return $ fmap toPathTemplate $ InstallDirs {-      prefix       = installPrefix,-      bindir       = "$prefix" </> "bin",-      libdir       = installLibDir,-      libsubdir    = case comp of-           Hugs   -> "hugs" </> "packages" </> "$pkg"-           JHC    -> "$compiler"-           LHC    -> "$compiler"-           UHC    -> "$pkgid"-           _other -> "$pkgid" </> "$compiler",-      dynlibdir    = "$libdir",-      libexecdir   = case buildOS of-        Windows   -> "$prefix" </> "$pkgid"-        _other    -> "$prefix" </> "libexec",-      progdir      = "$libdir" </> "hugs" </> "programs",-      includedir   = "$libdir" </> "$libsubdir" </> "include",-      datadir      = case buildOS of-        Windows   -> "$prefix"-        _other    -> "$prefix" </> "share",-      datasubdir   = "$pkgid",-      docdir       = "$datadir" </> "doc" </> "$pkgid",-      mandir       = "$datadir" </> "man",-      htmldir      = "$docdir"  </> "html",-      haddockdir   = "$htmldir"-  }---- ------------------------------------------------------------------------------ Converting directories, absolute or prefix-relative---- | Substitute the install dir templates into each other.------ To prevent cyclic substitutions, only some variables are allowed in--- particular dir templates. If out of scope vars are present, they are not--- substituted for. Checking for any remaining unsubstituted vars can be done--- as a subsequent operation.------ The reason it is done this way is so that in 'prefixRelativeInstallDirs' we--- 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 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],-      libexecdir = subst libexecdir prefixBinLibVars,-      progdir    = subst progdir    prefixBinLibVars,-      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])-    }-    subst dir env' = substPathTemplate (env'++env) (dir dirs)--    prefixVar        = (PrefixVar,     prefix     dirs')-    bindirVar        = (BindirVar,     bindir     dirs')-    libdirVar        = (LibdirVar,     libdir     dirs')-    libsubdirVar     = (LibsubdirVar,  libsubdir  dirs')-    datadirVar       = (DatadirVar,    datadir    dirs')-    datasubdirVar    = (DatasubdirVar, datasubdir dirs')-    docdirVar        = (DocdirVar,     docdir     dirs')-    htmldirVar       = (HtmldirVar,    htmldir    dirs')-    prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar]-    prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar]---- | Convert from abstract install directories to actual absolute ones by--- substituting for all the variables in the abstract paths, to get real--- absolute path.-absoluteInstallDirs :: PackageIdentifier -> CompilerId -> CopyDest-                    -> InstallDirs PathTemplate-                    -> InstallDirs FilePath-absoluteInstallDirs pkgId compilerId copydest dirs =-    (case copydest of-       CopyTo destdir -> fmap ((destdir </>) . dropDrive)-       _              -> id)-  . appendSubdirs (</>)-  . fmap fromPathTemplate-  $ substituteInstallDirTemplates env dirs-  where-    env = initialPathTemplateEnv pkgId compilerId----- |The location prefix for the /copy/ command.-data CopyDest-  = NoCopyDest-  | CopyTo FilePath-  deriving (Eq, Show)---- | 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 -> CompilerId-                          -> InstallDirTemplates-                          -> InstallDirs (Maybe FilePath)-prefixRelativeInstallDirs pkgId compilerId dirs =-    fmap relative-  . appendSubdirs combinePathTemplate-  $ -- 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]-    }-  where-    env = initialPathTemplateEnv pkgId compilerId--    -- If it starts with $prefix then it's relative and produce the relative-    -- 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 : rest) = Just rest-    relative' _                           = Nothing---- ------------------------------------------------------------------------------ Path templates---- | An abstract path, posibly containing variables that need to be--- substituted for to get a real 'FilePath'.----newtype PathTemplate = PathTemplate [PathComponent]--data PathComponent =-       Ordinary FilePath-     | Variable PathTemplateVariable-     deriving Eq--data PathTemplateVariable =-       PrefixVar     -- ^ The @$prefix@ path variable-     | BindirVar     -- ^ The @$bindir@ path variable-     | LibdirVar     -- ^ The @$libdir@ path variable-     | LibsubdirVar  -- ^ The @$libsubdir@ 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@-     | 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@-     | 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--type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]---- | Convert a 'FilePath' to a 'PathTemplate' including any template vars.----toPathTemplate :: FilePath -> PathTemplate-toPathTemplate = PathTemplate . read---- | Convert back to a path, any remaining vars are included----fromPathTemplate :: PathTemplate -> FilePath-fromPathTemplate (PathTemplate template) = show template--combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate-combinePathTemplate (PathTemplate t1) (PathTemplate t2) =-  PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2)--substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate-substPathTemplate environment (PathTemplate template) =-    PathTemplate (concatMap subst template)--    where subst component@(Ordinary _) = [component]-          subst component@(Variable variable) =-              case lookup variable environment of-                  Just (PathTemplate components) -> components-                  Nothing                        -> [component]---- | The initial environment has all the static stuff but no paths-initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> PathTemplateEnv-initialPathTemplateEnv pkgId compilerId =-     packageTemplateEnv  pkgId-  ++ compilerTemplateEnv compilerId-  ++ platformTemplateEnv buildPlatform -- platform should be param if we want-                                       -- to do cross-platform configuation--packageTemplateEnv :: PackageIdentifier -> PathTemplateEnv-packageTemplateEnv pkgId =-  [(PkgNameVar,  PathTemplate [Ordinary $ display (packageName pkgId)])-  ,(PkgVerVar,   PathTemplate [Ordinary $ display (packageVersion pkgId)])-  ,(PkgIdVar,    PathTemplate [Ordinary $ display pkgId])-  ]--compilerTemplateEnv :: CompilerId -> PathTemplateEnv-compilerTemplateEnv compilerId =-  [(CompilerVar, PathTemplate [Ordinary $ display compilerId])-  ]--platformTemplateEnv :: Platform -> PathTemplateEnv-platformTemplateEnv (Platform arch os) =-  [(OSVar,       PathTemplate [Ordinary $ display os])-  ,(ArchVar,     PathTemplate [Ordinary $ display arch])-  ]--installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv-installDirsTemplateEnv dirs =-  [(PrefixVar,     prefix     dirs)-  ,(BindirVar,     bindir     dirs)-  ,(LibdirVar,     libdir     dirs)-  ,(LibsubdirVar,  libsubdir  dirs)-  ,(DatadirVar,    datadir    dirs)-  ,(DatasubdirVar, datasubdir dirs)-  ,(DocdirVar,     docdir     dirs)-  ,(HtmldirVar,    htmldir    dirs)-  ]----- ------------------------------------------------------------------------------ Parsing and showing path templates:---- The textual format is that of an ordinary Haskell String, eg--- "$prefix/bin"--- and this gets parsed to the internal representation as a sequence of path--- spans which are either strings or variables, eg:--- PathTemplate [Variable PrefixVar, Ordinary "/bin" ]--instance Show PathTemplateVariable where-  show PrefixVar     = "prefix"-  show BindirVar     = "bindir"-  show LibdirVar     = "libdir"-  show LibsubdirVar  = "libsubdir"-  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 ExecutableNameVar = "executablename"-  show TestSuiteNameVar   = "test-suite"-  show TestSuiteResultVar = "result"-  show BenchmarkNameVar   = "benchmark"--instance Read PathTemplateVariable where-  readsPrec _ s =-    take 1-    [ (var, drop (length varStr) s)-    | (varStr, var) <- vars-    , varStr `isPrefixOf` s ]-    where vars = [("prefix",     PrefixVar)-                 ,("bindir",     BindirVar)-                 ,("libdir",     LibdirVar)-                 ,("libsubdir",  LibsubdirVar)-                 ,("datadir",    DatadirVar)-                 ,("datasubdir", DatasubdirVar)-                 ,("docdir",     DocdirVar)-                 ,("htmldir",    HtmldirVar)-                 ,("pkgid",      PkgIdVar)-                 ,("pkg",        PkgNameVar)-                 ,("version",    PkgVerVar)-                 ,("compiler",   CompilerVar)-                 ,("os",         OSVar)-                 ,("arch",       ArchVar)-                 ,("executablename", ExecutableNameVar)-                 ,("test-suite", TestSuiteNameVar)-                 ,("result", TestSuiteResultVar)-                 ,("benchmark", BenchmarkNameVar)]--instance Show PathComponent where-  show (Ordinary path) = path-  show (Variable var)  = '$':show var-  showList = foldr (\x -> (shows x .)) id--instance Read PathComponent where-  -- for some reason we colapse 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' ]--instance Show PathTemplate where-  show (PathTemplate template) = show (show template)--instance Read PathTemplate where-  readsPrec p s = [ (PathTemplate template, s')-                  | (path, s')     <- readsPrec p s-                  , (template, "") <- reads path ]---- ------------------------------------------------------------------------------ Internal utilities--getWindowsProgramFilesDir :: IO FilePath-getWindowsProgramFilesDir = do-#if mingw32_HOST_OS || mingw32_TARGET_OS-  m <- shGetFolderPath csidl_PROGRAM_FILES-#else-  let m = Nothing-#endif-  return (fromMaybe "C:\\Program Files" m)--#if mingw32_HOST_OS || mingw32_TARGET_OS-shGetFolderPath :: CInt -> IO (Maybe FilePath)-shGetFolderPath n =-# if __HUGS__-  return Nothing-# else-  allocaArray long_path_size $ \pPath -> do-     r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath-     if (r /= 0)-        then return Nothing-        else do s <- peekCWString pPath; return (Just s)-  where-    long_path_size      = 1024 -- MAX_PATH is 260, this should be plenty-# endif--csidl_PROGRAM_FILES :: CInt-csidl_PROGRAM_FILES = 0x0026--- csidl_PROGRAM_FILES_COMMON :: CInt--- csidl_PROGRAM_FILES_COMMON = 0x002b--foreign import stdcall unsafe "shlobj.h SHGetFolderPathW"-            c_SHGetFolderPath :: Ptr ()-                              -> CInt-                              -> Ptr ()-                              -> CInt-                              -> CWString-                              -> IO CInt-#endif--#if !(__HUGS__ || __GLASGOW_HASKELL__ > 606)--- Compat: this function only appears in FilePath > 1.0--- (which at the time of writing is unreleased)-dropDrive :: FilePath -> FilePath-dropDrive (c:cs) | isPathSeparator c = cs-dropDrive (_:':':c:cs) | isWindows-                      && isPathSeparator c = cs  -- path with drive letter-dropDrive (_:':':cs)   | isWindows         = cs-dropDrive cs = cs--isWindows :: Bool-isWindows = case buildOS of-  Windows -> True-  _       -> False-#endif
− Distribution/Simple/JHC.hs 
@@ -1,221 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.JHC--- Copyright   :  Isaac Jones 2003-2006------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module contains most of the JHC-specific code for configuring, building--- and installing packages.--{--Copyright (c) 2009, Henning Thielemann-Copyright (c) 2003-2005, Isaac Jones-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.JHC (-        configure, getInstalledPackages,-        buildLib, buildExe,-        installLib, installExe- ) where--import Distribution.PackageDescription as PD-       ( PackageDescription(..), BuildInfo(..), Executable(..)-       , Library(..), libModules, hcOptions, usedExtensions )-import Distribution.InstalledPackageInfo-         ( emptyInstalledPackageInfo, )-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-import Distribution.Simple.PackageIndex (PackageIndex)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) )-import Distribution.Simple.BuildPaths-                                ( autogenModulesDir, exeExtension )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..)-         , PackageDBStack, Flag, languageToFlags, extensionsToFlags )-import Language.Haskell.Extension-         ( Language(Haskell98), Extension(..), KnownExtension(..))-import Distribution.Simple.Program-         ( ConfiguredProgram(..), jhcProgram, ProgramConfiguration-         , userMaybeSpecifyPath, requireProgramVersion, lookupProgram-         , rawSystemProgram, rawSystemProgramStdoutConf )-import Distribution.Version-         ( Version(..), orLaterVersion )-import Distribution.Package-         ( Package(..), InstalledPackageId(InstalledPackageId),-           pkgName, pkgVersion, )-import Distribution.Simple.Utils-        ( createDirectoryIfMissingVerbose, writeFileAtomic-        , installOrdinaryFile, installExecutableFile-        , intercalate )-import System.FilePath          ( (</>) )-import Distribution.Verbosity-import Distribution.Text-         ( Text(parse), display )-import Distribution.Compat.ReadP-    ( readP_to_S, string, skipSpaces )--import Data.List                ( nub )-import Data.Char                ( isSpace )-import Data.Maybe               ( fromMaybe )----- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)-configure verbosity hcPath _hcPkgPath conf = do--  (jhcProg, _, conf') <- requireProgramVersion verbosity-                           jhcProgram (orLaterVersion (Version [0,7,2] []))-                           (userMaybeSpecifyPath "jhc" hcPath conf)--  let Just version = programVersion jhcProg-      comp = Compiler {-        compilerId             = CompilerId JHC version,-        compilerLanguages      = jhcLanguages,-        compilerExtensions     = jhcLanguageExtensions-      }-  return (comp, conf')--jhcLanguages :: [(Language, Flag)]-jhcLanguages = [(Haskell98, "")]---- | The flags for the supported extensions-jhcLanguageExtensions :: [(Extension, Flag)]-jhcLanguageExtensions =-    [(EnableExtension  TypeSynonymInstances       , "")-    ,(DisableExtension TypeSynonymInstances       , "")-    ,(EnableExtension  ForeignFunctionInterface   , "")-    ,(DisableExtension ForeignFunctionInterface   , "")-    ,(EnableExtension  ImplicitPrelude            , "") -- Wrong-    ,(DisableExtension ImplicitPrelude            , "--noprelude")-    ,(EnableExtension  CPP                        , "-fcpp")-    ,(DisableExtension CPP                        , "-fno-cpp")-    ]--getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration-                    -> IO PackageIndex-getInstalledPackages verbosity _packageDBs conf = do-   -- jhc --list-libraries lists all available libraries.-   -- How shall I find out, whether they are global or local-   -- without checking all files and locations?-   str <- rawSystemProgramStdoutConf verbosity jhcProgram conf ["--list-libraries"]-   let pCheck :: [(a, String)] -> [a]-       pCheck rs = [ r | (r,s) <- rs, all isSpace s ]-   let parseLine ln =-          pCheck (readP_to_S-             (skipSpaces >> string "Name:" >> skipSpaces >> parse) ln)-   return $-      PackageIndex.fromList $-      map (\p -> emptyInstalledPackageInfo {-                    InstalledPackageInfo.installedPackageId =-                       InstalledPackageId (display p),-                    InstalledPackageInfo.sourcePackageId = p-                 }) $-      concatMap parseLine $-      lines str---- -------------------------------------------------------------------------------- Building---- | Building a package for JHC.--- Currently C source files are not supported.-buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity pkg_descr lbi lib clbi = do-  let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi)-  let libBi = libBuildInfo lib-  let args  = constructJHCCmdLine lbi libBi clbi (buildDir lbi) verbosity-  let pkgid = display (packageId pkg_descr)-      pfile = buildDir lbi </> "jhc-pkg.conf"-      hlfile= buildDir lbi </> (pkgid ++ ".hl")-  writeFileAtomic pfile $ jhcPkgConf pkg_descr-  rawSystemProgram verbosity jhcProg $-     ["--build-hl="++pfile, "-o", hlfile] ++-     args ++ map display (libModules lib)---- | Building an executable for JHC.--- Currently C source files are not supported.-buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity _pkg_descr lbi exe clbi = do-  let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi)-  let exeBi = buildInfo exe-  let out   = buildDir lbi </> exeName exe-  let args  = constructJHCCmdLine lbi exeBi clbi (buildDir lbi) verbosity-  rawSystemProgram verbosity jhcProg (["-o",out] ++ args ++ [modulePath exe])--constructJHCCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo-                    -> FilePath -> Verbosity -> [String]-constructJHCCmdLine lbi bi clbi _odir verbosity =-        (if verbosity >= deafening then ["-v"] else [])-     ++ hcOptions JHC bi-     ++ languageToFlags (compiler lbi) (defaultLanguage bi)-     ++ extensionsToFlags (compiler lbi) (usedExtensions bi)-     ++ ["--noauto","-i-"]-     ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)]-     ++ ["-i", autogenModulesDir lbi]-     ++ ["-optc" ++ opt | opt <- PD.ccOptions bi]-     -- It would be better if JHC would accept package names with versions,-     -- but JHC-0.7.2 doesn't accept this.-     -- Thus, we have to strip the version with 'pkgName'.-     ++ (concat [ ["-p", display (pkgName pkgid)]-                | (_, pkgid) <- componentPackageDeps clbi ])--jhcPkgConf :: PackageDescription -> String-jhcPkgConf pd =-  let sline name sel = name ++ ": "++sel pd-      lib = fromMaybe (error "no library available") . library-      comma = intercalate "," . map display-  in unlines [sline "name" (display . pkgName . packageId)-             ,sline "version" (display . pkgVersion . packageId)-             ,sline "exposed-modules" (comma . PD.exposedModules . lib)-             ,sline "hidden-modules" (comma . otherModules . libBuildInfo . lib)-             ]--installLib :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Library -> IO ()-installLib verb dest build_dir pkg_descr _ = do-    let p = display (packageId pkg_descr)++".hl"-    createDirectoryIfMissingVerbose verb True dest-    installOrdinaryFile verb (build_dir </> p) (dest </> p)--installExe :: Verbosity -> FilePath -> FilePath -> (FilePath,FilePath) -> PackageDescription -> Executable -> IO ()-installExe verb dest build_dir (progprefix,progsuffix) _ exe = do-    let exe_name = exeName exe-        src = exe_name </> exeExtension-        out   = (progprefix ++ exe_name ++ progsuffix) </> exeExtension-    createDirectoryIfMissingVerbose verb True dest-    installExecutableFile verb (build_dir </> src) (dest </> out)-
− Distribution/Simple/LHC.hs 
@@ -1,805 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.LHC--- Copyright   :  Isaac Jones 2003-2007------ 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.--{- Copyright (c) 2003-2005, Isaac Jones-All rights reserved.--Redistribution and use in source and binary forms, with or without-modiication, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.LHC (-        configure, getInstalledPackages,-        buildLib, buildExe,-        installLib, installExe,-        registerPackage,-        ghcOptions,-        ghcVerbosityOptions- ) where--import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), Executable(..)-         , Library(..), libModules, hcOptions, usedExtensions, allExtensions )-import Distribution.InstalledPackageInfo-                                ( InstalledPackageInfo-                                , parseInstalledPackageInfo )-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-                                ( InstalledPackageInfo_(..) )-import Distribution.Simple.PackageIndex-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.ParseUtils  ( ParseResult(..) )-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) )-import Distribution.Simple.InstallDirs-import Distribution.Simple.BuildPaths-import Distribution.Simple.Utils-import Distribution.Package-         ( PackageIdentifier, Package(..) )-import qualified Distribution.ModuleName as ModuleName-import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg-         , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf-         , rawSystemProgramStdout, rawSystemProgramStdoutConf-         , requireProgramVersion-         , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram-         , arProgram, ranlibProgram, ldProgram-         , gccProgram, stripProgram-         , lhcProgram, lhcPkgProgram )-import qualified Distribution.Simple.Program.HcPkg as HcPkg-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion-         , OptimisationLevel(..), PackageDB(..), PackageDBStack-         , Flag, languageToFlags, extensionsToFlags )-import Distribution.Version-         ( Version(..), orLaterVersion )-import Distribution.System-         ( OS(..), buildOS )-import Distribution.Verbosity-import Distribution.Text-         ( display, simpleParse )-import Language.Haskell.Extension-         ( Language(Haskell98), Extension(..), KnownExtension(..) )--import Control.Monad            ( unless, when )-import Data.List-import Data.Maybe               ( catMaybes )-import Data.Monoid              ( Monoid(..) )-import System.Directory         ( removeFile, renameFile,-                                  getDirectoryContents, doesFileExist,-                                  getTemporaryDirectory )-import System.FilePath          ( (</>), (<.>), takeExtension,-                                  takeDirectory, replaceExtension )-import System.IO (hClose, hPutStrLn)-import Distribution.Compat.Exception (catchExit, catchIO)---- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)-configure verbosity hcPath hcPkgPath conf = do--  (lhcProg, lhcVersion, conf') <--    requireProgramVersion verbosity lhcProgram-      (orLaterVersion (Version [0,7] []))-      (userMaybeSpecifyPath "lhc" hcPath conf)--  (lhcPkgProg, lhcPkgVersion, conf'') <--    requireProgramVersion verbosity lhcPkgProgram-      (orLaterVersion (Version [0,7] []))-      (userMaybeSpecifyPath "lhc-pkg" hcPkgPath conf')--  when (lhcVersion /= lhcPkgVersion) $ die $-       "Version mismatch between lhc and lhc-pkg: "-    ++ programPath lhcProg ++ " is version " ++ display lhcVersion ++ " "-    ++ programPath lhcPkgProg ++ " is version " ++ display lhcPkgVersion--  languages  <- getLanguages  verbosity lhcProg-  extensions <- getExtensions verbosity lhcProg--  let comp = Compiler {-        compilerId             = CompilerId LHC lhcVersion,-        compilerLanguages      = languages,-        compilerExtensions     = extensions-      }-      conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld-  return (comp, conf''')---- | Adjust the way we find and configure gcc and ld----configureToolchain :: ConfiguredProgram -> ProgramConfiguration-                                        -> ProgramConfiguration-configureToolchain lhcProg =-    addKnownProgram gccProgram {-      programFindLocation = findProg gccProgram (baseDir </> "gcc.exe"),-      programPostConf     = configureGcc-    }-  . addKnownProgram ldProgram {-      programFindLocation = findProg ldProgram (libDir </> "ld.exe"),-      programPostConf     = configureLd-    }-  where-    compilerDir = takeDirectory (programPath lhcProg)-    baseDir     = takeDirectory compilerDir-    libDir      = baseDir </> "gcc-lib"-    includeDir  = baseDir </> "include" </> "mingw"-    isWindows   = case buildOS of Windows -> True; _ -> False--    -- on Windows finding and configuring ghc's gcc and ld is a bit special-    findProg :: Program -> FilePath -> Verbosity -> IO (Maybe FilePath)-    findProg prog location | isWindows = \verbosity -> do-        exists <- doesFileExist location-        if exists then return (Just location)-                  else do warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.")-                          programFindLocation prog verbosity-      | otherwise = programFindLocation prog--    configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg]-    configureGcc-      | isWindows = \_ gccProg -> case programLocation gccProg of-          -- if it's found on system then it means we're using the result-          -- of programFindLocation above rather than a user-supplied path-          -- that means we should add this extra flag to tell ghc's gcc-          -- where it lives and thus where gcc can find its various files:-          FoundOnSystem {} -> return ["-B" ++ libDir, "-I" ++ includeDir]-          UserSpecified {} -> return []-      | otherwise = \_ _   -> return []--    -- we need to find out if ld supports the -x flag-    configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg]-    configureLd verbosity ldProg = do-      tempDir <- getTemporaryDirectory-      ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->-             withTempFile tempDir ".o" $ \testofile testohnd -> do-               hPutStrLn testchnd "int foo() {}"-               hClose testchnd; hClose testohnd-               rawSystemProgram verbosity lhcProg ["-c", testcfile,-                                                   "-o", testofile]-               withTempFile tempDir ".o" $ \testofile' testohnd' ->-                 do-                   hClose testohnd'-                   _ <- rawSystemProgramStdout verbosity ldProg-                     ["-x", "-r", testofile, "-o", testofile']-                   return True-                 `catchIO`   (\_ -> return False)-                 `catchExit` (\_ -> return False)-      if ldx-        then return ["-x"]-        else return []--getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)]-getLanguages _ _ = return [(Haskell98, "")]---FIXME: does lhc support -XHaskell98 flag? from what version?--getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)]-getExtensions verbosity lhcProg = do-    exts <- rawSystemStdout verbosity (programPath lhcProg)-              ["--supported-languages"]-    -- GHC has the annoying habit of inverting some of the extensions-    -- so we have to try parsing ("No" ++ ghcExtensionName) first-    let readExtension str = do-          ext <- simpleParse ("No" ++ str)-          case ext of-            UnknownExtension _ -> simpleParse str-            _                  -> return ext-    return $ [ (ext, "-X" ++ display ext)-             | Just ext <- map readExtension (lines exts) ]--getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration-                     -> IO PackageIndex-getInstalledPackages verbosity packagedbs conf = do-  checkPackageDbStack packagedbs-  pkgss <- getInstalledPackages' verbosity packagedbs conf-  let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)-                | (_, pkgs) <- pkgss ]-  return $! (mconcat indexes)--  where-    -- 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-    Just ghcProg = lookupProgram lhcProgram conf-    compilerDir  = takeDirectory (programPath ghcProg)-    topDir       = takeDirectory compilerDir--checkPackageDbStack :: PackageDBStack -> IO ()-checkPackageDbStack (GlobalPackageDB:rest)-  | GlobalPackageDB `notElem` rest = return ()-checkPackageDbStack _ =-  die $ "GHC.getInstalledPackages: the global package db must be "-     ++ "specified first and cannot be specified multiple times"---- | Get the packages from specific PackageDBs, not cumulative.----getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration-                     -> IO [(PackageDB, [InstalledPackageInfo])]-getInstalledPackages' verbosity packagedbs conf-  =-  sequence-    [ do str <- rawSystemProgramStdoutConf verbosity lhcPkgProgram conf-                  ["dump", packageDbGhcPkgFlag packagedb]-           `catchExit` \_ -> die $ "ghc-pkg dump failed"-         case parsePackages str of-           Left ok -> return (packagedb, ok)-           _       -> die "failed to parse output of 'ghc-pkg dump'"-    | packagedb <- packagedbs ]--  where-    parsePackages str =-      let parsed = map parseInstalledPackageInfo (splitPkgs str)-       in case [ msg | ParseFailed msg <- parsed ] of-            []   -> Left [ pkg | ParseOk _ pkg <- parsed ]-            msgs -> Right msgs--    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--    packageDbGhcPkgFlag GlobalPackageDB          = "--global"-    packageDbGhcPkgFlag UserPackageDB            = "--user"-    packageDbGhcPkgFlag (SpecificPackageDB path) = "--package-conf=" ++ path---substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo-substTopDir topDir ipo- = ipo {-       InstalledPackageInfo.importDirs-           = map f (InstalledPackageInfo.importDirs ipo),-       InstalledPackageInfo.libraryDirs-           = map f (InstalledPackageInfo.libraryDirs ipo),-       InstalledPackageInfo.includeDirs-           = map f (InstalledPackageInfo.includeDirs ipo),-       InstalledPackageInfo.frameworkDirs-           = map f (InstalledPackageInfo.frameworkDirs ipo),-       InstalledPackageInfo.haddockInterfaces-           = map f (InstalledPackageInfo.haddockInterfaces ipo),-       InstalledPackageInfo.haddockHTMLs-           = map f (InstalledPackageInfo.haddockHTMLs ipo)-   }-    where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest-          f x = x---- -------------------------------------------------------------------------------- Building---- | Build a library with LHC.----buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity pkg_descr lbi lib clbi = do-  let pref = buildDir lbi-      pkgid = packageId pkg_descr-      runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)-      ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi)-      ifProfLib = when (withProfLib lbi)-      ifSharedLib = when (withSharedLib lbi)-      ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi)--  libBi <- hackThreadedFlag verbosity-             (compiler lbi) (withProfLib lbi) (libBuildInfo lib)--  let libTargetDir = pref-      forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi-      -- TH always needs vanilla libs, even when building for profiling--  createDirectoryIfMissingVerbose verbosity True libTargetDir-  -- TODO: do we need to put hs-boot files into place for mutually recurive modules?-  let ghcArgs =-             ["-package-name", display pkgid ]-          ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity-          ++ map display (libModules lib)-      lhcWrap x = ["--build-library", "--ghc-opts=" ++ unwords x]-      ghcArgsProf = ghcArgs-          ++ ["-prof",-              "-hisuf", "p_hi",-              "-osuf", "p_o"-             ]-          ++ ghcProfOptions libBi-      ghcArgsShared = ghcArgs-          ++ ["-dynamic",-              "-hisuf", "dyn_hi",-              "-osuf", "dyn_o", "-fPIC"-             ]-          ++ ghcSharedOptions libBi-  unless (null (libModules lib)) $-    do ifVanillaLib forceVanillaLib (runGhcProg $ lhcWrap ghcArgs)-       ifProfLib (runGhcProg $ lhcWrap ghcArgsProf)-       ifSharedLib (runGhcProg $ lhcWrap ghcArgsShared)--  -- build any C sources-  unless (null (cSources libBi)) $ do-     info verbosity "Building C Sources..."-     sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref-                                                        filename verbosity-                   createDirectoryIfMissingVerbose verbosity True odir-                   runGhcProg args-                   ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"]))-               | filename <- cSources libBi]--  -- link:-  info verbosity "Linking..."-  let cObjs = map (`replaceExtension` objExtension) (cSources libBi)-      cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi)-      vanillaLibFilePath = libTargetDir </> mkLibName pkgid-      profileLibFilePath = libTargetDir </> mkProfLibName pkgid-      sharedLibFilePath  = libTargetDir </> mkSharedLibName pkgid-                                              (compilerId (compiler lbi))-      ghciLibFilePath    = libTargetDir </> mkGHCiLibName pkgid--  stubObjs <- fmap catMaybes $ sequence-    [ findFileWithExtension [objExtension] [libTargetDir]-        (ModuleName.toFilePath x ++"_stub")-    | x <- libModules lib ]-  stubProfObjs <- fmap catMaybes $ sequence-    [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]-        (ModuleName.toFilePath x ++"_stub")-    | x <- libModules lib ]-  stubSharedObjs <- fmap catMaybes $ sequence-    [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]-        (ModuleName.toFilePath x ++"_stub")-    | x <- libModules lib ]--  hObjs     <- getHaskellObjects lib lbi-                    pref objExtension True-  hProfObjs <--    if (withProfLib lbi)-            then getHaskellObjects lib lbi-                    pref ("p_" ++ objExtension) True-            else return []-  hSharedObjs <--    if (withSharedLib lbi)-            then getHaskellObjects lib lbi-                    pref ("dyn_" ++ objExtension) False-            else return []--  unless (null hObjs && null cObjs && null stubObjs) $ do-    -- first remove library files if they exists-    sequence_-      [ removeFile libFilePath `catchIO` \_ -> return ()-      | libFilePath <- [vanillaLibFilePath, profileLibFilePath-                       ,sharedLibFilePath,  ghciLibFilePath] ]--    let arVerbosity | verbosity >= deafening = "v"-                    | verbosity >= normal = ""-                    | otherwise = "c"-        arArgs = ["q"++ arVerbosity]-            ++ [vanillaLibFilePath]-        arObjArgs =-               hObjs-            ++ map (pref </>) cObjs-            ++ stubObjs-        arProfArgs = ["q"++ arVerbosity]-            ++ [profileLibFilePath]-        arProfObjArgs =-               hProfObjs-            ++ map (pref </>) cObjs-            ++ stubProfObjs-        ldArgs = ["-r"]-            ++ ["-o", ghciLibFilePath <.> "tmp"]-        ldObjArgs =-               hObjs-            ++ map (pref </>) cObjs-            ++ stubObjs-        ghcSharedObjArgs =-               hSharedObjs-            ++ map (pref </>) 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 =-            [ "-no-auto-link-packages",-              "-shared",-              "-dynamic",-              "-o", sharedLibFilePath ]-            ++ ghcSharedObjArgs-            ++ ["-package-name", display pkgid ]-            ++ ghcPackageFlags lbi clbi-            ++ ["-l"++extraLib | extraLib <- extraLibs libBi]-            ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi]--        runLd ldLibName args = do-          exists <- doesFileExist ldLibName-            -- This method is called iteratively by xargs. The-            -- output goes to <ldLibName>.tmp, and any existing file-            -- named <ldLibName> is included when linking. The-            -- output is renamed to <libName>.-          rawSystemProgramConf verbosity ldProgram (withPrograms lbi)-            (args ++ if exists then [ldLibName] else [])-          renameFile (ldLibName <.> "tmp") ldLibName--        runAr = rawSystemProgramConf verbosity arProgram (withPrograms lbi)--         --TODO: 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-        maxCommandLineSize = 30 * 1024--    ifVanillaLib False $ xargs maxCommandLineSize-      runAr arArgs arObjArgs--    ifProfLib $ xargs maxCommandLineSize-      runAr arProfArgs arProfObjArgs--    ifGHCiLib $ xargs maxCommandLineSize-      (runLd ghciLibFilePath) ldArgs ldObjArgs--    ifSharedLib $ runGhcProg ghcSharedLinkArgs----- | Build an executable with LHC.----buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity _pkg_descr lbi-  exe@Executable { exeName = exeName', modulePath = modPath } clbi = do-  let pref = buildDir lbi-      runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)--  exeBi <- hackThreadedFlag verbosity-             (compiler lbi) (withProfExe lbi) (buildInfo exe)--  -- exeNameReal, the name that GHC really uses (with .exe on Windows)-  let exeNameReal = exeName' <.>-                    (if null $ takeExtension exeName' then exeExtension else "")--  let targetDir = pref </> exeName'-  let exeDir    = targetDir </> (exeName' ++ "-tmp")-  createDirectoryIfMissingVerbose verbosity True targetDir-  createDirectoryIfMissingVerbose verbosity True exeDir-  -- TODO: do we need to put hs-boot files into place for mutually recursive modules?-  -- FIX: what about exeName.hi-boot?--  -- build executables-  unless (null (cSources exeBi)) $ do-   info verbosity "Building C Sources."-   sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi-                                          exeDir filename verbosity-                 createDirectoryIfMissingVerbose verbosity True odir-                 runGhcProg args-             | filename <- cSources exeBi]--  srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath--  let cObjs = map (`replaceExtension` objExtension) (cSources exeBi)-  let lhcWrap x = ("--ghc-opts\"":x) ++ ["\""]-  let binArgs linkExe profExe =-             (if linkExe-                 then ["-o", targetDir </> exeNameReal]-                 else ["-c"])-          ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity-          ++ [exeDir </> x | x <- cObjs]-          ++ [srcMainFile]-          ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi]-          ++ ["-l"++lib | lib <- extraLibs exeBi]-          ++ ["-L"++libDir | libDir <- extraLibDirs exeBi]-          ++ concat [["-framework", f] | f <- PD.frameworks exeBi]-          ++ if profExe-                then ["-prof",-                      "-hisuf", "p_hi",-                      "-osuf", "p_o"-                     ] ++ ghcProfOptions exeBi-                else []--  -- For building exe's for profiling that use TH we actually-  -- have to build twice, once without profiling and the again-  -- with profiling. 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.-  when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi)-     (runGhcProg $ lhcWrap (binArgs False False))--  runGhcProg (binArgs True (withProfExe lbi))---- | Filter the "-threaded" flag when profiling as it does not---   work with ghc-6.8 and older.-hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo-hackThreadedFlag verbosity comp prof bi-  | not mustFilterThreaded = return bi-  | otherwise              = do-    warn verbosity $ "The ghc flag '-threaded' is not compatible with "-                  ++ "profiling in ghc-6.8 and older. It will be disabled."-    return bi { options = filterHcOptions (/= "-threaded") (options bi) }-  where-    mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] []-                      && "-threaded" `elem` hcOptions GHC bi-    filterHcOptions p hcoptss =-      [ (hc, if hc == GHC then filter p opts else opts)-      | (hc, opts) <- hcoptss ]---- when using -split-objs, we need to search for object files in the--- Module_split directory for each module.-getHaskellObjects :: Library -> LocalBuildInfo-                  -> FilePath -> String -> Bool -> IO [FilePath]-getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs-  | splitObjs lbi && allow_split_objs = do-        let dirs = [ pref </> (ModuleName.toFilePath x ++ "_split")-                   | x <- libModules lib ]-        objss <- mapM 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 <- libModules lib ]---constructGHCCmdLine-        :: LocalBuildInfo-        -> BuildInfo-        -> ComponentLocalBuildInfo-        -> FilePath-        -> Verbosity-        -> [String]-constructGHCCmdLine lbi bi clbi odir verbosity =-        ["--make"]-     ++ ghcVerbosityOptions verbosity-        -- Unsupported extensions have already been checked by configure-     ++ ghcOptions lbi bi clbi odir--ghcVerbosityOptions :: Verbosity -> [String]-ghcVerbosityOptions verbosity-     | verbosity >= deafening = ["-v"]-     | verbosity >= normal    = []-     | otherwise              = ["-w", "-v0"]--ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo-           -> FilePath -> [String]-ghcOptions lbi bi clbi odir-     =  ["-hide-all-packages"]-     ++ ghcPackageDbOptions (withPackageDB lbi)-     ++ (if splitObjs lbi then ["-split-objs"] else [])-     ++ ["-i"]-     ++ ["-i" ++ odir]-     ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]-     ++ ["-i" ++ autogenModulesDir lbi]-     ++ ["-I" ++ autogenModulesDir lbi]-     ++ ["-I" ++ odir]-     ++ ["-I" ++ dir | dir <- PD.includeDirs bi]-     ++ ["-optP" ++ opt | opt <- cppOptions bi]-     ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi </> cppHeaderName) ]-     ++ [ "-#include \"" ++ inc ++ "\"" | inc <- PD.includes bi ]-     ++ [ "-odir",  odir, "-hidir", odir ]-     ++ (if compilerVersion c >= Version [6,8] []-           then ["-stubdir", odir] else [])-     ++ ghcPackageFlags lbi clbi-     ++ (case withOptimization lbi of-           NoOptimisation      -> []-           NormalOptimisation  -> ["-O"]-           MaximumOptimisation -> ["-O2"])-     ++ hcOptions GHC bi-     ++ languageToFlags c (defaultLanguage bi)-     ++ extensionsToFlags c (usedExtensions bi)-    where c = compiler lbi--ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String]-ghcPackageFlags lbi clbi-  | ghcVer >= Version [6,11] []-              = concat [ ["-package-id", display ipkgid]-                       | (ipkgid, _) <- componentPackageDeps clbi ]--  | otherwise = concat [ ["-package", display pkgid]-                       | (_, pkgid)  <- componentPackageDeps clbi ]-    where-      ghcVer = compilerVersion (compiler lbi)--ghcPackageDbOptions :: PackageDBStack -> [String]-ghcPackageDbOptions 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)--constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo-                   -> FilePath -> FilePath -> Verbosity -> (FilePath,[String])-constructCcCmdLine lbi bi clbi pref filename verbosity-  =  let odir | compilerVersion (compiler lbi) >= Version [6,4,1] []  = pref-              | otherwise = pref </> takeDirectory filename-                        -- ghc 6.4.1 fixed a bug in -odir handling-                        -- for C compilations.-     in-        (odir,-         ghcCcOptions lbi bi clbi odir-         ++ (if verbosity >= deafening then ["-v"] else [])-         ++ ["-c",filename])---ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo-             -> FilePath -> [String]-ghcCcOptions lbi bi clbi odir-     =  ["-I" ++ dir | dir <- PD.includeDirs bi]-     ++ ghcPackageDbOptions (withPackageDB lbi)-     ++ ghcPackageFlags lbi clbi-     ++ ["-optc" ++ opt | opt <- PD.ccOptions bi]-     ++ (case withOptimization lbi of-           NoOptimisation -> []-           _              -> ["-optc-O2"])-     ++ ["-odir", odir]--mkGHCiLibName :: PackageIdentifier -> String-mkGHCiLibName lib = "HS" ++ display lib <.> "o"---- -------------------------------------------------------------------------------- Installing---- |Install executables for GHC.-installExe :: Verbosity-           -> LocalBuildInfo-           -> InstallDirs FilePath -- ^Where to copy the files to-           -> FilePath  -- ^Build location-           -> (FilePath, FilePath)  -- ^Executable (prefix,suffix)-           -> PackageDescription-           -> Executable-           -> IO ()-installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do-  let binDir = bindir installDirs-  createDirectoryIfMissingVerbose verbosity True binDir-  let exeFileName = exeName exe <.> exeExtension-      fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix-      installBinary dest = do-          installExecutableFile verbosity-            (buildPref </> exeName exe </> exeFileName)-            (dest <.> exeExtension)-          stripExe verbosity lbi exeFileName (dest <.> exeExtension)-  installBinary (binDir </> fixedExeBaseName)--stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO ()-stripExe verbosity lbi name path = when (stripExes lbi) $-  case lookupProgram stripProgram (withPrograms lbi) of-    Just strip -> rawSystemProgram verbosity strip args-    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 '" ++ name-                                ++ "' (missing the 'strip' program)"-  where-    args = path : case buildOS 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.-       _   -> []---- |Install for ghc, .hi, .a and, if --with-ghci given, .o-installLib    :: Verbosity-              -> LocalBuildInfo-              -> FilePath  -- ^install location-              -> FilePath  -- ^install location for dynamic librarys-              -> FilePath  -- ^Build location-              -> PackageDescription-              -> Library-              -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do-  -- copy .hi files over:-  let copy src dst n = do-        createDirectoryIfMissingVerbose verbosity True dst-        installOrdinaryFile verbosity (src </> n) (dst </> n)-      copyModuleFiles ext =-        findModuleFiles [builtDir] [ext] (libModules lib)-          >>= installOrdinaryFiles verbosity targetDir-  ifVanilla $ copyModuleFiles "hi"-  ifProf    $ copyModuleFiles "p_hi"-  hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib)-  flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase </> srcFile]--  -- copy the built library files over:-  ifVanilla $ copy builtDir targetDir vanillaLibName-  ifProf    $ copy builtDir targetDir profileLibName-  ifGHCi    $ copy builtDir targetDir ghciLibName-  ifShared  $ copy builtDir dynlibTargetDir sharedLibName--  -- run ranlib if necessary:-  ifVanilla $ updateLibArchive verbosity lbi-                               (targetDir </> vanillaLibName)-  ifProf    $ updateLibArchive verbosity lbi-                               (targetDir </> profileLibName)--  where-    vanillaLibName = mkLibName pkgid-    profileLibName = mkProfLibName pkgid-    ghciLibName    = mkGHCiLibName pkgid-    sharedLibName  = mkSharedLibName pkgid (compilerId (compiler lbi))--    pkgid          = packageId pkg--    hasLib    = not $ null (libModules lib)-                   && null (cSources (libBuildInfo lib))-    ifVanilla = when (hasLib && withVanillaLib lbi)-    ifProf    = when (hasLib && withProfLib    lbi)-    ifGHCi    = when (hasLib && withGHCiLib    lbi)-    ifShared  = when (hasLib && withSharedLib  lbi)--    runLhc    = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)---- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems--- like MacOS X. If we can't find those, don't worry too much about it.----updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()-updateLibArchive verbosity lbi path =-  case lookupProgram ranlibProgram (withPrograms lbi) of-    Just ranlib -> rawSystemProgram verbosity ranlib [path]-    Nothing     -> case lookupProgram arProgram (withPrograms lbi) of-      Just ar   -> rawSystemProgram verbosity ar ["-s", path]-      Nothing   -> warn verbosity $-                        "Unable to generate a symbol index for the static "-                     ++ "library '" ++ path-                     ++ "' (missing the 'ranlib' and 'ar' programs)"---- -------------------------------------------------------------------------------- Registering--registerPackage-  :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool-  -> PackageDBStack-  -> IO ()-registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do-  let Just lhcPkg = lookupProgram lhcPkgProgram (withPrograms lbi)-  HcPkg.reregister verbosity lhcPkg packageDbs (Right installedPkgInfo)
− Distribution/Simple/LocalBuildInfo.hs 
@@ -1,330 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.LocalBuildInfo--- Copyright   :  Isaac Jones 2003-2004------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Once a package has been configured we have resolved conditionals and--- dependencies, configured the compiler and other needed external programs.--- The 'LocalBuildInfo' is used to hold all this information. It holds the--- install dirs, the compiler, the exact package dependencies, the configured--- 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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.LocalBuildInfo (-        LocalBuildInfo(..),-        externalPackageDeps,-        inplacePackageId,--        -- * Buildable package components-        Component(..),-        foldComponent,-        allComponentsBy,-        ComponentName(..),-        ComponentLocalBuildInfo(..),-        withComponentsLBI,-        withLibLBI,-        withExeLBI,-        withTestLBI,--        -- * Installation directories-        module Distribution.Simple.InstallDirs,-        absoluteInstallDirs, prefixRelativeInstallDirs,-        substPathTemplate-  ) where---import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs,-                                               prefixRelativeInstallDirs,-                                               substPathTemplate, )-import qualified Distribution.Simple.InstallDirs as InstallDirs-import Distribution.Simple.Program (ProgramConfiguration)-import Distribution.PackageDescription-         ( PackageDescription(..), withLib, Library(libBuildInfo), withExe-         , Executable(exeName, buildInfo), withTest, TestSuite(..)-         , BuildInfo(buildable), Benchmark(..) )-import Distribution.Package-         ( PackageId, Package(..), InstalledPackageId(..) )-import Distribution.Simple.Compiler-         ( Compiler(..), PackageDBStack, OptimisationLevel )-import Distribution.Simple.PackageIndex-         ( PackageIndex )-import Distribution.Simple.Utils-         ( die )-import Distribution.Simple.Setup-         ( ConfigFlags )-import Distribution.Text-         ( display )--import Data.List (nub, find)---- | 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-        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 differnt-                -- kinds of files-        --TODO: inplaceDirTemplates :: InstallDirs FilePath-        compiler      :: Compiler,-                -- ^ The compiler we're building with-        buildDir      :: FilePath,-                -- ^ Where to build the package.-        --TODO: eliminate hugs's scratchDir, use builddir-        scratchDir    :: FilePath,-                -- ^ Where to put the result of the Hugs build.-        libraryConfig       :: Maybe ComponentLocalBuildInfo,-        executableConfigs   :: [(String, ComponentLocalBuildInfo)],-        compBuildOrder :: [ComponentName],-                -- ^ All the components to build, ordered by topological sort-                -- over the intrapackage dependency graph-        testSuiteConfigs    :: [(String, ComponentLocalBuildInfo)],-        benchmarkConfigs    :: [(String, ComponentLocalBuildInfo)],-        installedPkgs :: PackageIndex,-                -- ^ All the info about the installed packages that the-                -- current package depends on (directly or indirectly).-        pkgDescrFile  :: Maybe FilePath,-                -- ^ the filename containing the .cabal file, if available-        localPkgDescr :: PackageDescription,-                -- ^ The resolved package description, that does not contain-                -- any conditionals.-        withPrograms  :: ProgramConfiguration, -- ^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.-        withDynExe    :: Bool,  -- ^Whether to link executables dynamically-        withProfExe   :: Bool,  -- ^Whether to build executables for profiling.-        withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available).-        withGHCiLib   :: Bool,  -- ^Whether to build libs suitable for use with GHCi.-        splitObjs     :: Bool,  -- ^Use -split-objs with GHC, if available-        stripExes     :: Bool,  -- ^Whether to strip executables during install-        progPrefix    :: PathTemplate, -- ^Prefix to be prepended to installed executables-        progSuffix    :: PathTemplate -- ^Suffix to be appended to installed executables-  } deriving (Read, Show)---- | External package dependencies for the package as a whole. This is the--- union of the individual 'componentPackageDeps', less any internal deps.-externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)]-externalPackageDeps lbi = filter (not . internal . snd) $ nub $-  -- TODO:  what about non-buildable components?-       maybe [] componentPackageDeps (libraryConfig lbi)-    ++ concatMap (componentPackageDeps . snd) (executableConfigs lbi)-  where-    -- True if this dependency is an internal one (depends on the library-    -- defined in the same package).-    internal pkgid = pkgid == packageId (localPkgDescr lbi)---- | The installed package Id we use for local packages registered in the local--- package db. This is what is used for intra-package deps between components.----inplacePackageId :: PackageId -> InstalledPackageId-inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace")---- -------------------------------------------------------------------------------- Buildable components--data Component = CLib   Library-               | CExe   Executable-               | CTest  TestSuite-               | CBench Benchmark-               deriving (Show, Eq, Read)--data ComponentName = CLibName   -- currently only a single lib-                   | CExeName   String-                   | CTestName  String-                   | CBenchName String-                   deriving (Show, Eq, Read)--data ComponentLocalBuildInfo = ComponentLocalBuildInfo {-    -- | 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 :: [(InstalledPackageId, PackageId)]-  }-  deriving (Read, Show)--foldComponent :: (Library -> a)-              -> (Executable -> a)-              -> (TestSuite -> a)-              -> (Benchmark -> a)-              -> Component-              -> a-foldComponent f _ _ _ (CLib   lib) = f lib-foldComponent _ f _ _ (CExe   exe) = f exe-foldComponent _ _ f _ (CTest  tst) = f tst-foldComponent _ _ _ f (CBench bch) = f bch---- | Obtains all components (libs, exes, or test suites), transformed by the--- given function.  Useful for gathering dependencies with component context.-allComponentsBy :: PackageDescription-                -> (Component -> a)-                -> [a]-allComponentsBy pkg_descr f =-    [ f (CLib  lib) | Just lib <- [library pkg_descr]-                    , buildable (libBuildInfo lib) ]- ++ [ f (CExe  exe) | exe <- executables pkg_descr-                    , buildable (buildInfo exe) ]- ++ [ f (CTest tst) | tst <- testSuites pkg_descr-                    , buildable (testBuildInfo tst)-                    , testEnabled tst ]- ++ [ f (CBench bm) | bm <- benchmarks pkg_descr-                    , buildable (benchmarkBuildInfo bm)-                    , benchmarkEnabled bm ]---- |If the package description has a library section, call the given---  function with the library build info as argument.  Extended version of--- 'withLib' that also gives corresponding build info.-withLibLBI :: PackageDescription -> LocalBuildInfo-           -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO ()-withLibLBI pkg_descr lbi f = withLib pkg_descr $ \lib ->-  case libraryConfig lbi of-    Just clbi -> f lib clbi-    Nothing   -> die missingLibConf---- | Perform the action on each buildable 'Executable' in the package--- description.  Extended version of 'withExe' that also gives corresponding--- build info.-withExeLBI :: PackageDescription -> LocalBuildInfo-           -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO ()-withExeLBI pkg_descr lbi f = withExe pkg_descr $ \exe ->-  case lookup (exeName exe) (executableConfigs lbi) of-    Just clbi -> f exe clbi-    Nothing   -> die (missingExeConf (exeName exe))--withTestLBI :: PackageDescription -> LocalBuildInfo-            -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO ()-withTestLBI pkg_descr lbi f = withTest pkg_descr $ \test ->-  case lookup (testName test) (testSuiteConfigs lbi) of-    Just clbi -> f test clbi-    Nothing -> die (missingTestConf (testName test))---- | 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'-withComponentsLBI :: PackageDescription -> LocalBuildInfo-                  -> (Component -> ComponentLocalBuildInfo -> IO ())-                  -> IO ()-withComponentsLBI pkg_descr lbi f = mapM_ compF (compBuildOrder lbi)-  where-    compF CLibName =-        case library pkg_descr of-          Nothing  -> die missinglib-          Just lib -> case libraryConfig lbi of-                        Nothing   -> die missingLibConf-                        Just clbi -> f (CLib lib) clbi-      where-        missinglib  = "internal error: component list includes a library "-                   ++ "but the package description contains no library"--    compF (CExeName name) =-        case find (\exe -> exeName exe == name) (executables pkg_descr) of-          Nothing  -> die missingexe-          Just exe -> case lookup name (executableConfigs lbi) of-                        Nothing   -> die (missingExeConf name)-                        Just clbi -> f (CExe exe) clbi-      where-        missingexe  = "internal error: component list includes an executable "-                   ++ name ++ " but the package contains no such executable."--    compF (CTestName name) =-        case find (\tst -> testName tst == name) (testSuites pkg_descr) of-          Nothing  -> die missingtest-          Just tst -> case lookup name (testSuiteConfigs lbi) of-                        Nothing   -> die (missingTestConf name)-                        Just clbi -> f (CTest tst) clbi-      where-        missingtest = "internal error: component list includes a test suite "-                   ++ name ++ " but the package contains no such test suite."--    compF (CBenchName name) =-        case find (\bch -> benchmarkName bch == name) (benchmarks pkg_descr) of-          Nothing  -> die missingbench-          Just bch -> case lookup name (benchmarkConfigs lbi) of-                        Nothing   -> die (missingBenchConf name)-                        Just clbi -> f (CBench bch) clbi-      where-        missingbench = "internal error: component list includes a benchmark "-                       ++ name ++ " but the package contains no such benchmark."--missingLibConf :: String-missingExeConf, missingTestConf, missingBenchConf :: String -> String--missingLibConf       = "internal error: the package contains a library "-                    ++ "but there is no corresponding configuration data"-missingExeConf  name = "internal error: the package contains an executable "-                    ++ name ++ " but there is no corresponding configuration data"-missingTestConf name = "internal error: the package contains a test suite "-                    ++ name ++ " but there is no corresponding configuration data"-missingBenchConf name = "internal error: the package contains a benchmark "-                    ++ name ++ " but there is no corresponding configuration data"----- -------------------------------------------------------------------------------- Wrappers for a couple functions from InstallDirs---- |See 'InstallDirs.absoluteInstallDirs'-absoluteInstallDirs :: PackageDescription -> LocalBuildInfo -> CopyDest-                    -> InstallDirs FilePath-absoluteInstallDirs pkg lbi copydest =-  InstallDirs.absoluteInstallDirs-    (packageId pkg)-    (compilerId (compiler lbi))-    copydest-    (installDirTemplates lbi)---- |See 'InstallDirs.prefixRelativeInstallDirs'-prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo-                          -> InstallDirs (Maybe FilePath)-prefixRelativeInstallDirs pkg_descr lbi =-  InstallDirs.prefixRelativeInstallDirs-    (packageId pkg_descr)-    (compilerId (compiler lbi))-    (installDirTemplates lbi)--substPathTemplate :: PackageId -> LocalBuildInfo-                  -> PathTemplate -> FilePath-substPathTemplate pkgid lbi = fromPathTemplate-                                . ( InstallDirs.substPathTemplate env )-    where env = initialPathTemplateEnv-                   pkgid-                   (compilerId (compiler lbi))
− Distribution/Simple/NHC.hs 
@@ -1,424 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.NHC--- Copyright   :  Isaac Jones 2003-2006---                Duncan Coutts 2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module contains most of the NHC-specific code for configuring, building--- and installing packages.--{- Copyright (c) 2003-2005, Isaac Jones-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.NHC (-    configure,-    getInstalledPackages,-    buildLib,-    buildExe,-    installLib,-    installExe,-  ) where--import Distribution.Package-         ( PackageName, PackageIdentifier(..), InstalledPackageId(..)-         , packageId, packageName )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo-         , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId-                                , sourcePackageId )-         , emptyInstalledPackageInfo, parseInstalledPackageInfo )-import Distribution.PackageDescription-        ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)-        , hcOptions, usedExtensions )-import Distribution.ModuleName (ModuleName)-import qualified Distribution.ModuleName as ModuleName-import Distribution.Simple.LocalBuildInfo-        ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) )-import Distribution.Simple.BuildPaths-        ( mkLibName, objExtension, exeExtension )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..)-         , Flag, languageToFlags, extensionsToFlags-         , PackageDB(..), PackageDBStack )-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)-import Language.Haskell.Extension-         ( Language(Haskell98), Extension(..), KnownExtension(..) )-import Distribution.Simple.Program-         ( ProgramConfiguration, userMaybeSpecifyPath, programPath-         , requireProgram, requireProgramVersion, lookupProgram-         , nhcProgram, hmakeProgram, ldProgram, arProgram-         , rawSystemProgramConf )-import Distribution.Simple.Utils-        ( die, info, findFileWithExtension, findModuleFiles-        , installOrdinaryFile, installExecutableFile, installOrdinaryFiles-        , createDirectoryIfMissingVerbose, withUTF8FileContents )-import Distribution.Version-        ( Version(..), orLaterVersion )-import Distribution.Verbosity-import Distribution.Text-         ( display, simpleParse )-import Distribution.ParseUtils-         ( ParseResult(..) )--import System.FilePath-        ( (</>), (<.>), normalise, takeDirectory, dropExtension )-import System.Directory-         ( doesFileExist, doesDirectoryExist, getDirectoryContents-         , removeFile, getHomeDirectory )--import Data.Char ( toLower )-import Data.List ( nub )-import Data.Maybe    ( catMaybes )-import Data.Monoid   ( Monoid(..) )-import Control.Monad ( when, unless )-import Distribution.Compat.Exception---- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)-configure verbosity hcPath _hcPkgPath conf = do--  (_nhcProg, nhcVersion, conf') <--    requireProgramVersion verbosity nhcProgram-      (orLaterVersion (Version [1,20] []))-      (userMaybeSpecifyPath "nhc98" hcPath conf)--  (_hmakeProg, _hmakeVersion, conf'') <--    requireProgramVersion verbosity hmakeProgram-     (orLaterVersion (Version [3,13] [])) conf'-  (_ldProg, conf''')   <- requireProgram verbosity ldProgram conf''-  (_arProg, conf'''')  <- requireProgram verbosity arProgram conf'''--  --TODO: put this stuff in a monad so we can say just:-  -- requireProgram hmakeProgram (orLaterVersion (Version [3,13] []))-  -- requireProgram ldProgram anyVersion-  -- requireProgram ldPrograrProgramam anyVersion-  -- unless (null (cSources bi)) $ requireProgram ccProgram anyVersion--  let comp = Compiler {-        compilerId         = CompilerId NHC nhcVersion,-        compilerLanguages  = nhcLanguages,-        compilerExtensions     = nhcLanguageExtensions-      }-  return (comp, conf'''')--nhcLanguages :: [(Language, Flag)]-nhcLanguages = [(Haskell98, "-98")]---- | The flags for the supported extensions-nhcLanguageExtensions :: [(Extension, Flag)]-nhcLanguageExtensions =-    -- TODO: pattern guards in 1.20-     -- NHC doesn't enforce the monomorphism restriction at all.-     -- Technically it therefore doesn't support MonomorphismRestriction,-     -- but that would mean it doesn't support Haskell98, so we pretend-     -- that it does.-    [(EnableExtension  MonomorphismRestriction,   "")-    ,(DisableExtension MonomorphismRestriction,   "")-     -- Similarly, I assume the FFI is always on-    ,(EnableExtension  ForeignFunctionInterface,  "")-    ,(DisableExtension ForeignFunctionInterface,  "")-     -- Similarly, I assume existential quantification is always on-    ,(EnableExtension  ExistentialQuantification, "")-    ,(DisableExtension ExistentialQuantification, "")-     -- Similarly, I assume empty data decls is always on-    ,(EnableExtension  EmptyDataDecls,            "")-    ,(DisableExtension EmptyDataDecls,            "")-    ,(EnableExtension  NamedFieldPuns,            "-puns")-    ,(DisableExtension NamedFieldPuns,            "-nopuns")-     -- CPP can't actually be turned off, but we pretend that it can-    ,(EnableExtension  CPP,                       "-cpp")-    ,(DisableExtension CPP,                       "")-    ]--getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration-                     -> IO PackageIndex-getInstalledPackages verbosity packagedbs conf = do-  homedir      <- getHomeDirectory-  (nhcProg, _) <- requireProgram verbosity nhcProgram conf-  let bindir = takeDirectory (programPath nhcProg)-      incdir = takeDirectory bindir </> "include" </> "nhc98"-      dbdirs = nub (concatMap (packageDbPaths homedir incdir) packagedbs)-  indexes  <- mapM getIndividualDBPackages dbdirs-  return $! mconcat indexes--  where-    getIndividualDBPackages :: FilePath -> IO PackageIndex-    getIndividualDBPackages dbdir = do-      pkgdirs <- getPackageDbDirs dbdir-      pkgs    <- sequence [ getInstalledPackage pkgname pkgdir-                          | (pkgname, pkgdir) <- pkgdirs ]-      let pkgs' = map setInstalledPackageId (catMaybes pkgs)-      return (PackageIndex.fromList pkgs')--packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]-packageDbPaths _home incdir db = case db of-  GlobalPackageDB        -> [ incdir </> "packages" ]-  UserPackageDB          -> [] --TODO any standard per-user db?-  SpecificPackageDB path -> [ path ]--getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)]-getPackageDbDirs dbdir = do-  dbexists <- doesDirectoryExist dbdir-  if not dbexists-    then return []-    else do-      entries  <- getDirectoryContents dbdir-      pkgdirs  <- sequence-        [ do pkgdirExists <- doesDirectoryExist pkgdir-             return (pkgname, pkgdir, pkgdirExists)-        | (entry, Just pkgname) <- [ (entry, simpleParse entry)-                                   | entry <- entries ]-        , let pkgdir = dbdir </> entry ]-      return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ]--getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo)-getInstalledPackage pkgname pkgdir = do-  let pkgconfFile = pkgdir </> "package.conf"-  pkgconfExists <- doesFileExist pkgconfFile--  let cabalFile = pkgdir <.> "cabal"-  cabalExists <- doesFileExist cabalFile--  case () of-    _ | pkgconfExists -> getFullInstalledPackageInfo pkgname pkgconfFile-      | cabalExists   -> getPhonyInstalledPackageInfo pkgname cabalFile-      | otherwise     -> return Nothing--getFullInstalledPackageInfo :: PackageName -> FilePath-                            -> IO (Maybe InstalledPackageInfo)-getFullInstalledPackageInfo pkgname pkgconfFile =-  withUTF8FileContents pkgconfFile $ \contents ->-    case parseInstalledPackageInfo contents of-      ParseOk _ pkginfo | packageName pkginfo == pkgname-                        -> return (Just pkginfo)-      _                 -> return Nothing---- | This is a backup option for existing versions of nhc98 which do not supply--- proper installed package info files for the bundled libs. Instead we look--- for the .cabal file and extract the package version from that.--- We don't know any other details for such packages, in particular we pretend--- that they have no dependencies.----getPhonyInstalledPackageInfo :: PackageName -> FilePath-                             -> IO (Maybe InstalledPackageInfo)-getPhonyInstalledPackageInfo pkgname pathsModule = do-  content <- readFile pathsModule-  case extractVersion content of-    Nothing      -> return Nothing-    Just version -> return (Just pkginfo)-      where-        pkgid   = PackageIdentifier pkgname version-        pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid }-  where-    -- search through the .cabal file, looking for a line like:-    ---    -- > version: 2.0-    ---    extractVersion :: String -> Maybe Version-    extractVersion content =-      case catMaybes (map extractVersionLine (lines content)) of-        [version] -> Just version-        _         -> Nothing-    extractVersionLine :: String -> Maybe Version-    extractVersionLine line =-      case words line of-        [versionTag, ":", versionStr]-          | map toLower versionTag == "version"  -> simpleParse versionStr-        [versionTag,      versionStr]-          | map toLower versionTag == "version:" -> simpleParse versionStr-        _                                        -> Nothing---- Older installed package info files did not have the installedPackageId--- field, so if it is missing then we fill it as the source package ID.-setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo-setInstalledPackageId pkginfo@InstalledPackageInfo {-                        installedPackageId = InstalledPackageId "",-                        sourcePackageId    = pkgid-                      }-                    = pkginfo {-                        --TODO use a proper named function for the conversion-                        -- from source package id to installed package id-                        installedPackageId = InstalledPackageId (display pkgid)-                      }-setInstalledPackageId pkginfo = pkginfo---- -------------------------------------------------------------------------------- Building---- |FIX: For now, the target must contain a main module.  Not used--- ATM. Re-add later.-buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity pkg_descr lbi lib clbi = do-  let conf = withPrograms lbi-      Just nhcProg = lookupProgram nhcProgram conf-  let bi = libBuildInfo lib-      modules = exposedModules lib ++ otherModules bi-      -- Unsupported extensions have already been checked by configure-      languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi)-                   ++ extensionsToFlags (compiler lbi) (usedExtensions bi)-  inFiles <- getModulePaths lbi bi modules-  let targetDir = buildDir lbi-      srcDirs  = nub (map takeDirectory inFiles)-      destDirs = map (targetDir </>) srcDirs-  mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs-  rawSystemProgramConf verbosity hmakeProgram conf $-       ["-hc=" ++ programPath nhcProg]-    ++ nhcVerbosityOptions verbosity-    ++ ["-d", targetDir, "-hidir", targetDir]-    ++ maybe [] (hcOptions NHC . libBuildInfo)-                           (library pkg_descr)-    ++ languageFlags-    ++ concat [ ["-package", display (packageName pkgid) ]-              | (_, pkgid) <- componentPackageDeps clbi ]-    ++ inFiles-{--  -- build any C sources-  unless (null (cSources bi)) $ do-     info verbosity "Building C Sources..."-     let commonCcArgs = (if verbosity >= deafening then ["-v"] else [])-                     ++ ["-I" ++ dir | dir <- includeDirs bi]-                     ++ [opt | opt <- ccOptions bi]-                     ++ (if withOptimization lbi then ["-O2"] else [])-     flip mapM_ (cSources bi) $ \cfile -> do-       let ofile = targetDir </> cfile `replaceExtension` objExtension-       createDirectoryIfMissingVerbose verbosity True (takeDirectory ofile)-       rawSystemProgramConf verbosity hmakeProgram conf-         (commonCcArgs ++ ["-c", cfile, "-o", ofile])--}-  -- link:-  info verbosity "Linking..."-  let --cObjs = [ targetDir </> cFile `replaceExtension` objExtension-      --        | cFile <- cSources bi ]-      libFilePath = targetDir </> mkLibName (packageId pkg_descr)-      hObjs = [ targetDir </> ModuleName.toFilePath m <.> objExtension-              | m <- modules ]--  unless (null hObjs {-&& null cObjs-}) $ do-    -- first remove library if it exists-    removeFile libFilePath `catchIO` \_ -> return ()--    let arVerbosity | verbosity >= deafening = "v"-                    | verbosity >= normal = ""-                    | otherwise = "c"--    rawSystemProgramConf verbosity arProgram (withPrograms lbi) $-         ["q"++ arVerbosity, libFilePath]-      ++ hObjs---    ++ cObjs---- | Building an executable for NHC.-buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity pkg_descr lbi exe clbi = do-  let conf = withPrograms lbi-      Just nhcProg = lookupProgram nhcProgram conf-  when (dropExtension (modulePath exe) /= exeName exe) $-    die $ "hmake does not support exe names that do not match the name of "-       ++ "the 'main-is' file. You will have to rename your executable to "-       ++ show (dropExtension (modulePath exe))-  let bi = buildInfo exe-      modules = otherModules bi-      -- Unsupported extensions have already been checked by configure-      languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi)-                   ++ extensionsToFlags (compiler lbi) (usedExtensions bi)-  inFiles <- getModulePaths lbi bi modules-  let targetDir = buildDir lbi </> exeName exe-      exeDir    = targetDir </> (exeName exe ++ "-tmp")-      srcDirs   = nub (map takeDirectory (modulePath exe : inFiles))-      destDirs  = map (exeDir </>) srcDirs-  mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs-  rawSystemProgramConf verbosity hmakeProgram conf $-       ["-hc=" ++ programPath nhcProg]-    ++ nhcVerbosityOptions verbosity-    ++ ["-d", targetDir, "-hidir", targetDir]-    ++ maybe [] (hcOptions NHC . libBuildInfo)-                           (library pkg_descr)-    ++ languageFlags-    ++ concat [ ["-package", display (packageName pkgid) ]-              | (_, pkgid) <- componentPackageDeps clbi ]-    ++ inFiles-    ++ [exeName exe]--nhcVerbosityOptions :: Verbosity -> [String]-nhcVerbosityOptions verbosity-     | verbosity >= deafening = ["-v"]-     | verbosity >= normal    = []-     | otherwise              = ["-q"]----TODO: where to put this? it's duplicated in .Simple too-getModulePaths :: LocalBuildInfo -> BuildInfo -> [ModuleName] -> IO [FilePath]-getModulePaths lbi bi modules = sequence-   [ findFileWithExtension ["hs", "lhs"] (buildDir lbi : hsSourceDirs bi)-       (ModuleName.toFilePath module_) >>= maybe (notFound module_) (return . normalise)-   | module_ <- modules ]-   where notFound module_ = die $ "can't find source for module " ++ display module_---- -------------------------------------------------------------------------------- Installing---- |Install executables for NHC.-installExe :: Verbosity -- ^verbosity-           -> FilePath  -- ^install location-           -> FilePath  -- ^Build location-           -> (FilePath, FilePath)  -- ^Executable (prefix,suffix)-           -> Executable-           -> IO ()-installExe verbosity pref buildPref (progprefix,progsuffix) exe-    = do createDirectoryIfMissingVerbose verbosity True pref-         let exeBaseName = exeName exe-             exeFileName = exeBaseName <.> exeExtension-             fixedExeFileName = (progprefix ++ exeBaseName ++ progsuffix) <.> exeExtension-         installExecutableFile verbosity-           (buildPref </> exeBaseName </> exeFileName)-           (pref </> fixedExeFileName)---- |Install for nhc98: .hi and .a files-installLib    :: Verbosity -- ^verbosity-              -> FilePath  -- ^install location-              -> FilePath  -- ^Build location-              -> PackageIdentifier-              -> Library-              -> IO ()-installLib verbosity pref buildPref pkgid lib-    = do let bi = libBuildInfo lib-             modules = exposedModules lib ++ otherModules bi-         findModuleFiles [buildPref] ["hi"] modules-           >>= installOrdinaryFiles verbosity pref-         let libName = mkLibName pkgid-         installOrdinaryFile verbosity (buildPref </> libName) (pref </> libName)
− Distribution/Simple/PackageIndex.hs 
@@ -1,562 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.PackageIndex--- Copyright   :  (c) David Himmelstrup 2005,---                    Bjorn Bringert 2007,---                    Duncan Coutts 2008-2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ An index of packages.----module Distribution.Simple.PackageIndex (-  -- * Package index data type-  PackageIndex,--  -- * Creating an index-  fromList,--  -- * Updates-  merge,--  insert,--  deleteInstalledPackageId,-  deleteSourcePackageId,-  deletePackageName,---  deleteDependency,--  -- * Queries--  -- ** Precise lookups-  lookupInstalledPackageId,-  lookupSourcePackageId,-  lookupPackageName,-  lookupDependency,--  -- ** Case-insensitive searches-  searchByName,-  SearchResult(..),-  searchByNameSubstring,--  -- ** Bulk queries-  allPackages,-  allPackagesByName,--  -- ** Special queries-  brokenPackages,-  dependencyClosure,-  reverseDependencyClosure,-  topologicalOrder,-  reverseTopologicalOrder,-  dependencyInconsistencies,-  dependencyCycles,-  dependencyGraph,-  moduleNameIndex,-  ) where--import Prelude hiding (lookup)-import Control.Exception (assert)-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.Tree  as Tree-import qualified Data.Graph as Graph-import qualified Data.Array as Array-import Data.Array ((!))-import Data.List as List-         ( null, foldl', sort-         , groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy )-import Data.Monoid (Monoid(..))-import Data.Maybe (isNothing, fromMaybe)--import Distribution.Package-         ( PackageName(..), PackageId-         , Package(..), packageName, packageVersion-         , Dependency(Dependency)--, --PackageFixedDeps(..)-         , InstalledPackageId(..) )-import Distribution.ModuleName-         ( ModuleName )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo, installedPackageId )-import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.Version-         ( Version, withinRange )-import Distribution.Simple.Utils (lowercase, comparing, equating)----- | The collection of information about packages from one or more 'PackageDB's.------ Packages are uniquely identified in by their 'InstalledPackageId', they can--- also be effeciently looked up by package name or by name and version.----data PackageIndex = PackageIndex-  -- The primary index. Each InstalledPackageInfo record is uniquely identified-  -- by its InstalledPackageId.-  ---  !(Map InstalledPackageId InstalledPackageInfo)--  -- This auxillary 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 InstalledPackageId-  -- and are kept in preference order.-  ---  !(Map PackageName (Map Version [InstalledPackageInfo]))--  deriving (Show, Read)--instance Monoid PackageIndex where-  mempty  = PackageIndex Map.empty Map.empty-  mappend = merge-  --save one mappend with empty in the common case:-  mconcat [] = mempty-  mconcat xs = foldr1 mappend xs--invariant :: PackageIndex -> Bool-invariant (PackageIndex pids pnames) =-     map installedPackageId (Map.elems pids)-  == sort-     [ assert pinstOk (installedPackageId pinst)-     | (pname, pvers)  <- Map.toList pnames-     , let pversOk = not (Map.null pvers)-     , (pver,  pinsts) <- assert pversOk $ Map.toList pvers-     , let pinsts'  = sortBy (comparing installedPackageId) pinsts-           pinstsOk = all (\g -> length g == 1)-                          (groupBy (equating installedPackageId) pinsts')-     , pinst           <- assert pinstsOk $ pinsts'-     , let pinstOk = packageName    pinst == pname-                  && packageVersion pinst == pver-     ]-------- * Internal helpers-----mkPackageIndex :: Map InstalledPackageId InstalledPackageInfo-               -> Map PackageName (Map Version [InstalledPackageInfo])-               -> PackageIndex-mkPackageIndex pids pnames = assert (invariant index) index-  where index = PackageIndex pids pnames-------- * Construction------- | Build an index out of a bunch of packages.------ If there are duplicates by 'InstalledPackageId' then later ones mask earlier--- ones.----fromList :: [InstalledPackageInfo] -> PackageIndex-fromList pkgs = mkPackageIndex pids pnames-  where-    pids      = Map.fromList [ (installedPackageId pkg, pkg) | pkg <- pkgs ]-    pnames    =-      Map.fromList-        [ (packageName (head pkgsN), pvers)-        | pkgsN <- groupBy (equating  packageName)-                 . sortBy  (comparing packageId)-                 $ pkgs-        , let pvers =-                Map.fromList-                [ (packageVersion (head pkgsNV),-                   nubBy (equating installedPackageId) (reverse pkgsNV))-                | pkgsNV <- groupBy (equating packageVersion) pkgsN-                ]-        ]------- * Updates------- | Merge two indexes.------ Packages from the second mask packages from the first if they have the exact--- same 'InstalledPackageId'.------ For packages with the same source 'PackageId', packages from the second are--- \"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 :: PackageIndex -> PackageIndex -> PackageIndex-merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) =-  mkPackageIndex (Map.union 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 installedPackageId)----- | Inserts a single package into the index.------ This is equivalent to (but slightly quicker than) using 'mappend' or--- 'merge' with a singleton index.----insert :: InstalledPackageInfo -> PackageIndex -> PackageIndex-insert pkg (PackageIndex pids pnames) =-    mkPackageIndex pids' pnames'--  where-    pids'   = Map.insert (installedPackageId pkg) pkg pids-    pnames' = insertPackageName pnames-    insertPackageName =-      Map.insertWith' (\_ -> insertPackageVersion)-                     (packageName pkg)-                     (Map.singleton (packageVersion pkg) [pkg])--    insertPackageVersion =-      Map.insertWith' (\_ -> insertPackageInstance)-                     (packageVersion pkg) [pkg]--    insertPackageInstance pkgs =-      pkg : deleteBy (equating installedPackageId) pkg pkgs----- | Removes a single installed package from the index.----deleteInstalledPackageId :: InstalledPackageId -> PackageIndex -> PackageIndex-deleteInstalledPackageId ipkgid original@(PackageIndex pids pnames) =-  case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of-    (Nothing,     _)     -> original-    (Just spkgid, pids') -> mkPackageIndex pids'-                                          (deletePkgName spkgid pnames)--  where-    deletePkgName spkgid =-      Map.update (deletePkgVersion spkgid) (packageName spkgid)--    deletePkgVersion spkgid =-        (\m -> if Map.null m then Nothing else Just m)-      . Map.update deletePkgInstance (packageVersion spkgid)--    deletePkgInstance =-        (\xs -> if List.null xs then Nothing else Just xs)-      . List.deleteBy (\_ pkg -> installedPackageId pkg == ipkgid) undefined----- | Removes all packages with this source 'PackageId' from the index.----deleteSourcePackageId :: PackageId -> PackageIndex -> PackageIndex-deleteSourcePackageId pkgid original@(PackageIndex pids pnames) =-  case Map.lookup (packageName pkgid) pnames of-    Nothing     -> original-    Just pvers  -> case Map.lookup (packageVersion pkgid) pvers of-      Nothing   -> original-      Just pkgs -> mkPackageIndex-                     (foldl' (flip (Map.delete . installedPackageId)) pids pkgs)-                     (deletePkgName pnames)-  where-    deletePkgName =-      Map.update deletePkgVersion (packageName pkgid)--    deletePkgVersion =-        (\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.----deletePackageName :: PackageName -> PackageIndex -> PackageIndex-deletePackageName name original@(PackageIndex pids pnames) =-  case Map.lookup name pnames of-    Nothing     -> original-    Just pvers  -> mkPackageIndex-                     (foldl' (flip (Map.delete . installedPackageId)) pids-                             (concat (Map.elems pvers)))-                     (Map.delete name pnames)--{---- | Removes all packages satisfying this dependency from the index.----deleteDependency :: Dependency -> PackageIndex -> PackageIndex-deleteDependency (Dependency name verstionRange) =-  delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange)--}------- * Bulk queries------- | Get all the packages from the index.----allPackages :: PackageIndex -> [InstalledPackageInfo]-allPackages (PackageIndex pids _) = Map.elems pids---- | Get all the packages from the index.------ They are grouped by package name, case-sensitively.----allPackagesByName :: PackageIndex -> [[InstalledPackageInfo]]-allPackagesByName (PackageIndex _ pnames) =-  concatMap Map.elems (Map.elems pnames)------- * Lookups------- | Does a lookup by source package id (name & version).------ Since multiple package DBs mask each other by 'InstalledPackageId',--- then we get back at most one package.----lookupInstalledPackageId :: PackageIndex -> InstalledPackageId-                         -> Maybe InstalledPackageInfo-lookupInstalledPackageId (PackageIndex pids _) pid = Map.lookup pid pids----- | Does a lookup by source package id (name & version).------ There can be multiple installed packages with the same source 'PackageId'--- but different 'InstalledPackageId'. They are returned in order of--- preference, with the most preferred first.----lookupSourcePackageId :: PackageIndex -> PackageId -> [InstalledPackageInfo]-lookupSourcePackageId (PackageIndex _ pnames) pkgid =-  case Map.lookup (packageName pkgid) pnames of-    Nothing     -> []-    Just pvers  -> case Map.lookup (packageVersion pkgid) pvers of-      Nothing   -> []-      Just pkgs -> pkgs -- in preference order----- | Does a lookup by source package name.----lookupPackageName :: PackageIndex -> PackageName-                  -> [(Version, [InstalledPackageInfo])]-lookupPackageName (PackageIndex _ pnames) name =-  case Map.lookup name pnames of-    Nothing     -> []-    Just pvers  -> Map.toList pvers----- | Does a lookup by source package name and a range of versions.------ We get back any number of versions of the specified package name, all--- satisfying the version range constraint.----lookupDependency :: PackageIndex -> Dependency-                 -> [(Version, [InstalledPackageInfo])]-lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) =-  case Map.lookup name pnames of-    Nothing    -> []-    Just pvers -> [ entry-                  | entry@(ver, _) <- Map.toList pvers-                  , ver `withinRange` versionRange ]------- * Case insensitive name lookups------- | Does a case-insensitive search by package name.------ If there is only one package that compares case-insentiviely to this name--- then the search is unambiguous and we get back all versions of that package.--- If several match case-insentiviely but one matches exactly then it is also--- unambiguous.------ If however several match case-insentiviely and none match exactly then we--- 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 -> String -> SearchResult [InstalledPackageInfo]-searchByName (PackageIndex _ pnames) name =-  case [ pkgs | pkgs@(PackageName name',_) <- Map.toList pnames-              , lowercase name' == lname ] of-    []               -> None-    [(_,pvers)]      -> Unambiguous (concat (Map.elems pvers))-    pkgss            -> case find ((PackageName name==) . 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 -> String -> [InstalledPackageInfo]-searchByNameSubstring (PackageIndex _ pnames) searchterm =-  [ pkg-  | (PackageName name, pvers) <- Map.toList pnames-  , lsearchterm `isInfixOf` lowercase name-  , pkgs <- Map.elems pvers-  , pkg <- pkgs ]-  where lsearchterm = lowercase searchterm-------- * Special queries------- None of the stuff below depends on the internal representation of the index.------- | Find if there are any cycles in the dependency graph. If there are no--- cycles the result is @[]@.------ 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 :: PackageIndex -> [[InstalledPackageInfo]]-dependencyCycles index =-  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]-  where-    adjacencyList = [ (pkg, installedPackageId pkg, IPI.depends 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 :: PackageIndex -> [(InstalledPackageInfo, [InstalledPackageId])]-brokenPackages index =-  [ (pkg, missing)-  | pkg  <- allPackages index-  , let missing = [ pkg' | pkg' <- IPI.depends pkg-                         , isNothing (lookupInstalledPackageId index pkg') ]-  , not (null missing) ]----- | Tries to take the transitive closure of the package dependencies.------ If the transitive closure is complete then it returns that subset of the--- index. Otherwise it returns the broken packages as in 'brokenPackages'.------ * 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 :: PackageIndex-                  -> [InstalledPackageId]-                  -> Either PackageIndex-                            [(InstalledPackageInfo, [InstalledPackageId])]-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 lookupInstalledPackageId index pkgid of-      Nothing   -> closure completed (pkgid:failed) pkgids-      Just pkg  -> case lookupInstalledPackageId completed (installedPackageId pkg) of-        Just _  -> closure completed  failed pkgids-        Nothing -> closure completed' failed pkgids'-          where completed' = insert pkg completed-                pkgids'    = IPI.depends pkg ++ pkgids---- | Takes the transitive closure of the packages reverse dependencies.------ * The given 'PackageId's must be in the index.----reverseDependencyClosure :: PackageIndex-                         -> [InstalledPackageId]-                         -> [InstalledPackageInfo]-reverseDependencyClosure index =-    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 :: PackageIndex -> [InstalledPackageInfo]-topologicalOrder index = map toPkgId-                       . Graph.topSort-                       $ graph-  where (graph, toPkgId, _) = dependencyGraph index--reverseTopologicalOrder :: PackageIndex -> [InstalledPackageInfo]-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 :: PackageIndex-                -> (Graph.Graph,-                    Graph.Vertex -> InstalledPackageInfo,-                    InstalledPackageId -> Maybe Graph.Vertex)-dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex)-  where-    graph = Array.listArray bounds-              [ [ v | Just v <- map id_to_vertex (IPI.depends pkg) ]-              | pkg <- pkgs ]--    pkgs             = sortBy (comparing packageId) (allPackages index)-    vertices         = zip (map installedPackageId 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-    topBound = length pkgs - 1-    bounds = (0, topBound)---- | Given a package index where we assume we want to use all the packages--- (use 'dependencyClosure' if you need to get such a index subset) find out--- if the dependencies within it use consistent versions of each package.--- Return all cases where multiple packages depend on different versions of--- some other package.------ 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 :: PackageIndex-                          -> [(PackageName, [(PackageId, Version)])]-dependencyInconsistencies index =-  [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids])-  | (name, ipid_map) <- Map.toList inverseIndex-  , let uses = Map.elems ipid_map-  , reallyIsInconsistent (map fst uses) ]--  where -- for each PackageName,-        --   for each package with that name,-        --     the InstalledPackageInfo and the package Ids of packages-        --     that depend on it.-        inverseIndex :: Map PackageName-                            (Map InstalledPackageId-                                 (InstalledPackageInfo, [PackageId]))-        inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))-          [ (packageName dep,-             Map.fromList [(ipid,(dep,[packageId pkg]))])-          | pkg <- allPackages index-          , ipid <- IPI.depends pkg-          , Just dep <- [lookupInstalledPackageId index ipid]-          ]--        reallyIsInconsistent :: [InstalledPackageInfo] -> Bool-        reallyIsInconsistent []       = False-        reallyIsInconsistent [_p]     = False-        reallyIsInconsistent [p1, p2] =-             installedPackageId p1 `notElem` IPI.depends p2-          && installedPackageId p2 `notElem` IPI.depends p1-        reallyIsInconsistent _ = True---moduleNameIndex :: PackageIndex -> Map ModuleName [InstalledPackageInfo]-moduleNameIndex index =-  Map.fromListWith (++)-    [ (moduleName, [pkg])-    | pkg        <- allPackages index-    , moduleName <- IPI.exposedModules pkg ]
− Distribution/Simple/PreProcess.hs 
@@ -1,608 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.PreProcess--- Copyright   :  (c) 2003-2005, Isaac Jones, Malcolm Wallace------ 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.--{- Copyright (c) 2003-2005, Isaac Jones, Malcolm Wallace-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.PreProcess (preprocessComponent, knownSuffixHandlers,-                                ppSuffixes, PPSuffixHandler, PreProcessor(..),-                                mkSimplePreProcessor, runSimplePreProcessor,-                                ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs,-                                ppHappy, ppAlex, ppUnlit-                               )-    where---import Control.Monad-import Distribution.Simple.PreProcess.Unlit (unlit)-import Distribution.Package-         ( Package(..), PackageName(..) )-import qualified Distribution.ModuleName as ModuleName-import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..)-         , Executable(..)-         , Library(..), libModules-         , TestSuite(..), testModules-         , TestSuiteInterface(..)-         , Benchmark(..), benchmarkModules, BenchmarkInterface(..) )-import qualified Distribution.InstalledPackageInfo as Installed-         ( InstalledPackageInfo_(..) )-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion )-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), Component(..) )-import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName)-import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File-         , die, setupMessage, intercalate, copyFileVerbose-         , findFileWithExtension, findFileWithExtension' )-import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), programPath-         , lookupProgram, requireProgram, requireProgramVersion-         , rawSystemProgramConf, rawSystemProgram-         , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram-         , happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram )-import Distribution.Simple.Test ( writeSimpleTestStub, stubFilePath, stubName )-import Distribution.System-         ( OS(OSX, Windows), buildOS )-import Distribution.Text-import Distribution.Version-         ( Version(..), anyVersion, orLaterVersion )-import Distribution.Verbosity--import Data.Maybe (fromMaybe)-import Data.List (nub)-import System.Directory (getModificationTime, doesFileExist)-import System.Info (os, arch)-import System.FilePath (splitExtension, dropExtensions, (</>), (<.>),-                        takeDirectory, normalise, replaceExtension)---- |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 genereated 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 genereated 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-  -- inlcuded into a source tarball.-  platformIndependent :: Bool,--  -- TODO: deal with pre-processors that have implementaion dependent output-  --       eg alex and happy have --ghc flags. However we can't really inlcude-  --       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-  }--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 -> PreProcessor)---- | Apply preprocessors to the sources from 'hsSourceDirs' for a given--- component (lib, exe, or test suite).-preprocessComponent :: PackageDescription-                    -> Component-                    -> LocalBuildInfo-                    -> Bool-                    -> Verbosity-                    -> [PPSuffixHandler]-                    -> IO ()-preprocessComponent pd comp lbi isSrcDist verbosity handlers = case comp of-  (CLib lib@Library{ libBuildInfo = bi }) -> do-    let dirs = hsSourceDirs bi ++ [autogenModulesDir lbi]-    setupMessage verbosity "Preprocessing library" (packageId pd)-    forM_ (map ModuleName.toFilePath $ libModules lib) $-      pre dirs (buildDir lbi) (localHandlers bi)-  (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do-    let exeDir = buildDir lbi </> nm </> nm ++ "-tmp"-        dirs   = hsSourceDirs bi ++ [autogenModulesDir lbi]-    setupMessage verbosity ("Preprocessing executable '" ++ nm ++ "' for") (packageId pd)-    forM_ (map ModuleName.toFilePath $ otherModules bi) $-      pre dirs exeDir (localHandlers bi)-    pre (hsSourceDirs bi) exeDir (localHandlers bi) $-      dropExtensions (modulePath exe)-  CTest test@TestSuite{ testName = nm } -> do-    setupMessage verbosity ("Preprocessing test suite '" ++ nm ++ "' for") (packageId pd)-    case testInterface test of-      TestSuiteExeV10 _ f ->-          preProcessTest test f $ buildDir lbi </> testName test-              </> testName test ++ "-tmp"-      TestSuiteLibV09 _ _ -> do-          let testDir = buildDir lbi </> stubName test-                  </> stubName test ++ "-tmp"-          writeSimpleTestStub test testDir-          preProcessTest test (stubFilePath test) testDir-      TestSuiteUnsupported tt -> die $ "No support for preprocessing test "-                                    ++ "suite type " ++ display tt-  CBench bm@Benchmark{ benchmarkName = nm } -> do-    setupMessage verbosity ("Preprocessing benchmark '" ++ nm ++ "' for") (packageId pd)-    case benchmarkInterface bm of-      BenchmarkExeV10 _ f ->-          preProcessBench bm f $ buildDir lbi </> benchmarkName bm-              </> benchmarkName bm ++ "-tmp"-      BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark "-                                 ++ "type " ++ display tt-  where-    builtinSuffixes-      | NHC == compilerFlavor (compiler lbi) = ["hs", "lhs", "gc"]-      | otherwise                            = ["hs", "lhs"]-    localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers]-    pre dirs dir lhndlrs fp =-      preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs-    preProcessTest test = preProcessComponent (testBuildInfo test)-                          (testModules test)-    preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm)-                         (benchmarkModules bm)-    preProcessComponent bi modules exePath dir = do-        let biHandlers = localHandlers bi-            sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ]-        sequence_ [ preprocessFile sourceDirs (buildDir lbi) isSrcDist-                (ModuleName.toFilePath modu) verbosity builtinSuffixes-                biHandlers-                | modu <- modules ]-        preprocessFile (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-    :: [FilePath]               -- ^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) 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 : searchLoc) baseFile-                 case bsrcFiles of-                  Nothing -> die $ "can't find source for " ++ baseFile-                                ++ " in " ++ intercalate ", " 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 "Internal error in preProcess module: Just expected")-                               (lookup (tailNotNull 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 -> do-                              btime <- getModificationTime ppsrcFile-                              ptime <- getModificationTime psrcFile-                              return (btime < ptime)-              when recomp $ do-                let destDir = buildLoc </> dirName srcStem-                createDirectoryIfMissingVerbose verbosity True destDir-                runPreProcessorWithHsBootHack pp-                   (psrcLoc, psrcRelFile)-                   (buildLoc, srcStem <.> "hs")--  where-    dirName = takeDirectory-    tailNotNull [] = []-    tailNotNull x  = tail x--    -- 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 -> PreProcessor-ppGreenCard _ lbi-    = PreProcessor {-        platformIndependent = False,-        runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->-          rawSystemProgramConf 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 (unlit inFile contents)-  }--ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor-ppCpp = ppCpp' []--ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor-ppCpp' extraArgs bi lbi =-  case compilerFlavor (compiler lbi) of-    GHC -> ppGhcCpp (cppArgs ++ extraArgs) bi lbi-    _   -> ppCpphs  (cppArgs ++ extraArgs) bi lbi--  where cppArgs = getCppOptions bi lbi--ppGhcCpp :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor-ppGhcCpp extraArgs _bi lbi =-  PreProcessor {-    platformIndependent = False,-    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do-      (ghcProg, ghcVersion, _) <- requireProgramVersion verbosity-                                    ghcProgram anyVersion (withPrograms lbi)-      rawSystemProgram verbosity ghcProg $-          ["-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 ghcVersion >= Version [6,6] [] then ["-x", "hs"] else [])-       ++ (if use_optP_P lbi then ["-optP-P"] else [])-       ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi </> cppHeaderName) ]-       ++ ["-o", outFile, inFile]-       ++ extraArgs-  }--ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor-ppCpphs extraArgs _bi lbi =-  PreProcessor {-    platformIndependent = False,-    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do-      (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity-                                        cpphsProgram anyVersion (withPrograms lbi)-      rawSystemProgram verbosity cpphsProg $-          ("-O" ++ outFile) : inFile-        : "--noline" : "--strip"-        : (if cpphsVersion >= Version [1,6] []-             then ["--include="++ (autogenModulesDir lbi </> cppHeaderName)]-             else [])-        ++ extraArgs-  }---- Haddock versions before 0.8 choke on #line and #file pragmas.  Those--- pragmas are necessary for correct links when we preprocess.  So use--- -optP-P only if the Haddock version is prior to 0.8.-use_optP_P :: LocalBuildInfo -> Bool-use_optP_P lbi- = case lookupProgram haddockProgram (withPrograms lbi) of-     Just (ConfiguredProgram { programVersion = Just version })-       | version >= Version [0,8] [] -> False-     _                               -> True--ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor-ppHsc2hs bi lbi =-  PreProcessor {-    platformIndependent = False,-    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do-      (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)-      rawSystemProgramConf verbosity hsc2hsProgram (withPrograms lbi) $-          [ "--cc=" ++ programPath gccProg-          , "--ld=" ++ programPath gccProg ]--          -- 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 <- hcDefines (compiler lbi) ]-       ++ [ "--cflag="   ++ opt | opt <- sysDefines ]--          -- Options from the current package:-       ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs  bi ]-       ++ [ "--cflag="   ++ opt | opt <- PD.ccOptions    bi-                                      ++ PD.cppOptions   bi ]-       ++ [ "--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 ]-                ++ [ "-I" ++ autogenModulesDir lbi,-                     "-include", autogenModulesDir lbi </> cppHeaderName ] ]-       ++ [ "--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 ] ]-       ++ ["-o", outFile, inFile]-  }-  where-    pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))-    isOSX = case buildOS of OSX -> True; _ -> False-    isELF = case buildOS of OSX -> False; Windows -> False; _ -> True;-    packageHacks = case compilerFlavor (compiler lbi) of-      GHC -> 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 (it's ld is a tad stricter than gnu ld). Thus we remove the-    -- ldOptions for GHC's rts package:-    hackRtsPackage index =-      case PackageIndex.lookupPackageName index (PackageName "rts") of-        [(_, [rts])]-           -> PackageIndex.insert rts { Installed.ldOptions = [] } index-        _  -> error "No (or multiple) ghc rts package is registered!!"---ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor-ppC2hs bi lbi =-  PreProcessor {-    platformIndependent = False,-    runPreProcessor = \(inBaseDir, inRelativeFile)-                       (outBaseDir, outRelativeFile) verbosity -> do-      (c2hsProg, _, _) <- requireProgramVersion verbosity-                            c2hsProgram (orLaterVersion (Version [0,15] []))-                            (withPrograms lbi)-      (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)-      rawSystemProgram verbosity c2hsProg $--          -- Options from the current package:-           [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ]-        ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ]-        ++ [ "--include=" ++ outBaseDir ]--          -- Options from dependent packages-       ++ [ "--cppopts=" ++ opt-          | pkg <- pkgs-          , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ]-                ++ [         opt | opt@('-':c:_) <- Installed.ccOptions pkg-                                 , 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)----TODO: perhaps use this with hsc2hs too---TODO: remove cc-options from cpphs for cabal-version: >= 1.10-getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]-getCppOptions bi lbi-    = hcDefines (compiler lbi)-   ++ sysDefines-   ++ cppOptions bi-   ++ ["-I" ++ dir | dir <- PD.includeDirs bi]-   ++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"]--sysDefines :: [String]-sysDefines = ["-D" ++ os   ++ "_" ++ loc ++ "_OS"   | loc <- locations]-          ++ ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations]-  where-    locations = ["BUILD", "HOST"]--hcDefines :: Compiler -> [String]-hcDefines comp =-  case compilerFlavor comp of-    GHC  -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version]-    JHC  -> ["-D__JHC__=" ++ versionInt version]-    NHC  -> ["-D__NHC__=" ++ versionInt version]-    Hugs -> ["-D__HUGS__"]-    _    -> []-  where version = compilerVersion 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 (Version { versionBranch = [] }) = "1"-versionInt (Version { versionBranch = [n] }) = show n-versionInt (Version { versionBranch = 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--ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor-ppHappy _ lbi = pp { platformIndependent = True }-  where pp = standardPP lbi happyProgram (hcFlags hc)-        hc = compilerFlavor (compiler lbi)-        hcFlags GHC = ["-agc"]-        hcFlags _ = []--ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor-ppAlex _ lbi = pp { platformIndependent = True }-  where pp = standardPP lbi alexProgram (hcFlags hc)-        hc = compilerFlavor (compiler lbi)-        hcFlags GHC = ["-g"]-        hcFlags _ = []--standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor-standardPP lbi prog args =-  PreProcessor {-    platformIndependent = False,-    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->-      rawSystemProgramConf 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)-  ]
− Distribution/Simple/PreProcess/Unlit.hs 
@@ -1,165 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.PreProcess.Unlit--- Copyright   :  ...------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ 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 Data.Char-import Data.List--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-                                  && length file >= 2-                                  && head file == '"'-                                  && last file == '"'-                                -> Line (read line) (tail (init file))-                     _          -> 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---- 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---- | 'unlit' takes a filename (for error reports), and transforms the---   given string, to eliminate the literate comments from the program text.-unlit :: FilePath -> String -> Either String String-unlit file input =-  let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks-                                   . inlines-                                   $ input-   in either (Left . unlines . map (unclassify usesBirdTracks))-              Right-    . checkErrors-    . reclassify-    $ classified--  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-    -- style literate code typically gets indented by two since ">" is replaced-    -- by " " and people usually use one additional space of indent ie-    -- "> then the code". On the other hand we cannot just go and indent all-    -- the comments by two since that does not work for latex style literate-    -- code. So the hacky solution we use here is that if we see any bird track-    -- style code then we'll indent all comments by two, otherwise by none.-    -- Of course this will not work for mixed latex/bird track .lhs files but-    -- nobody does that, it's silly and specifically recommended against in the-    -- H98 unlit spec.-    ---    classifyAndCheckForBirdTracks =-      flip mapAccumL False $ \seenBirdTrack line ->-        let classification = classify line-         in (seenBirdTrack || isBirdTrack classification, classification)--    isBirdTrack (BirdTrack _) = True-    isBirdTrack _             = False--    checkErrors ls = case [ e | Error e <- ls ] of-      []          -> Left  ls-      (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message)-        where (f, n) = errorPos file 1 ls-    errorPos f n []              = (f, n)-    errorPos f n (Error _:_)     = (f, n)-    errorPos _ _ (Line n' f':ls) = errorPos f' n' ls-    errorPos f n (_         :ls) = errorPos f  (n+1) ls---- Here we model a state machine, with each state represented by--- a local function. We only have four states (well, five,--- if you count the error state), but the rules--- to transition between then are not so simple.--- Would it be simpler to have more states?------ Each state represents the type of line that was last read--- i.e. are we in a comment section, or a latex-code section,--- or a bird-code section, etc?-reclassify :: [Classified] -> [Classified]-reclassify = blank -- begin in blank state-  where-    latex []               = []-    latex (EndCode    :ls) = Blank "" : comment ls-    latex (BeginCode  :_ ) = [Error "\\begin{code} in code section"]-    latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls-    latex (          l:ls) = l : latex ls--    blank []               = []-    blank (EndCode    :_ ) = [Error "\\end{code} without \\begin{code}"]-    blank (BeginCode  :ls) = Blank ""    : latex ls-    blank (BirdTrack l:ls) = BirdTrack l : bird ls-    blank (Ordinary  l:ls) = Comment   l : comment ls-    blank (          l:ls) =           l : blank ls--    bird []              = []-    bird (EndCode   :_ ) = [Error "\\end{code} without \\begin{code}"]-    bird (BeginCode :ls) = Blank "" : latex ls-    bird (Blank l   :ls) = Blank l  : blank ls-    bird (Ordinary _:_ ) = [Error "program line before comment line"]-    bird (         l:ls) = l : bird ls--    comment []               = []-    comment (EndCode    :_ ) = [Error "\\end{code} without \\begin{code}"]-    comment (BeginCode  :ls) = Blank "" : latex ls-    comment (CPP l      :ls) = CPP l : comment ls-    comment (BirdTrack _:_ ) = [Error "comment line before program line"]-    -- 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---- 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:))--internalError :: a-internalError = error "unlit: internal error"
− Distribution/Simple/Program.hs 
@@ -1,218 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Program--- Copyright   :  Isaac Jones 2006, Duncan Coutts 2007-2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This provides an abstraction which deals with configuring and running--- programs. A 'Program' is a static notion of a known program. A--- 'ConfiguredProgram' is a 'Program' that has been found on the current--- machine and is ready to be run (possibly with some user-supplied default--- args). Configuring a program involves finding its location and if necessary--- finding its version. There is also a 'ProgramConfiguration' type which holds--- configured and not-yet configured programs. It is the parameter to lots of--- actions elsewhere in Cabal that need to look up and run programs. If we had--- a Cabal monad, the 'ProgramConfiguration' would probably be a reader or--- state component of it. ------ The module also defines all the known built-in 'Program's and the--- 'defaultProgramConfiguration' which contains them all.------ One nice thing about using it is that any program that is--- registered with Cabal will get some \"configure\" and \".cabal\"--- helpers like --with-foo-args --foo-path= and extra-foo-args.------ There's also good default behavior for trying to find \"foo\" in--- PATH, being able to override its location, etc.------ There's also a hook for adding programs in a Setup.lhs script.  See--- 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(..)-    , simpleProgram-    , findProgramLocation-    , findProgramVersion--    -- * Configured program and related functions-    , ConfiguredProgram(..)-    , programPath-    , ProgArg-    , ProgramLocation(..)-    , runProgram-    , getProgramOutput--    -- * Program invocations-    , ProgramInvocation(..)-    , emptyProgramInvocation-    , simpleProgramInvocation-    , programInvocation-    , runProgramInvocation-    , getProgramInvocationOutput--    -- * The collection of unconfigured and configured progams-    , builtinPrograms--    -- * The collection of configured programs we can run-    , ProgramConfiguration-    , emptyProgramConfiguration-    , defaultProgramConfiguration-    , restoreProgramConfiguration-    , addKnownProgram-    , addKnownPrograms-    , lookupKnownProgram-    , knownPrograms-    , userSpecifyPath-    , userSpecifyPaths-    , userMaybeSpecifyPath-    , userSpecifyArgs-    , userSpecifyArgss-    , userSpecifiedArgs-    , lookupProgram-    , updateProgram-    , configureProgram-    , configureAllKnownPrograms-    , reconfigurePrograms-    , requireProgram-    , requireProgramVersion-    , runDbProgram-    , getDbProgramOutput--    -- * Programs that Cabal knows about-    , ghcProgram-    , ghcPkgProgram-    , lhcProgram-    , lhcPkgProgram-    , nhcProgram-    , hmakeProgram-    , jhcProgram-    , hugsProgram-    , ffihugsProgram-    , uhcProgram-    , gccProgram-    , ranlibProgram-    , arProgram-    , stripProgram-    , happyProgram-    , alexProgram-    , hsc2hsProgram-    , c2hsProgram-    , cpphsProgram-    , hscolourProgram-    , haddockProgram-    , greencardProgram-    , ldProgram-    , tarProgram-    , cppProgram-    , pkgConfigProgram-    , hpcProgram--    -- * deprecated-    , rawSystemProgram-    , rawSystemProgramStdout-    , rawSystemProgramConf-    , rawSystemProgramStdoutConf-    , findProgramOnPath--    ) where--import Distribution.Simple.Program.Types-import Distribution.Simple.Program.Run-import Distribution.Simple.Program.Db-import Distribution.Simple.Program.Builtin--import Distribution.Simple.Utils-         ( die, findProgramLocation, findProgramVersion )-import Distribution.Verbosity-         ( Verbosity )----- | Runs the given configured program.----runProgram :: Verbosity          -- ^Verbosity-           -> ConfiguredProgram  -- ^The program to run-           -> [ProgArg]          -- ^Any /extra/ arguments to add-           -> IO ()-runProgram verbosity prog args =-  runProgramInvocation verbosity (programInvocation prog args)----- | Runs the given configured program and gets the output.----getProgramOutput :: Verbosity          -- ^Verbosity-                 -> ConfiguredProgram  -- ^The program to run-                 -> [ProgArg]          -- ^Any /extra/ arguments to add-                 -> IO String-getProgramOutput verbosity 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 programDb args =-  case lookupProgram prog programDb of-    Nothing             -> die notFound-    Just configuredProg -> runProgram verbosity configuredProg args- where-   notFound = "The program " ++ programName prog-           ++ " is required but it could not be found"---- | Looks up the given program in the program database and runs it.----getDbProgramOutput :: Verbosity  -- ^verbosity-                   -> Program    -- ^The program to run-                   -> ProgramDb  -- ^look up the program here-                   -> [ProgArg]  -- ^Any /extra/ arguments to add-                   -> IO String-getDbProgramOutput verbosity prog programDb args =-  case lookupProgram prog programDb of-    Nothing             -> die notFound-    Just configuredProg -> getProgramOutput verbosity configuredProg args- where-   notFound = "The program " ++ programName prog-           ++ " is required but it could not be found"--------------------------- Deprecated aliases-----rawSystemProgram :: Verbosity -> ConfiguredProgram-                 -> [ProgArg] -> IO ()-rawSystemProgram = runProgram--rawSystemProgramStdout :: Verbosity -> ConfiguredProgram-                       -> [ProgArg] -> IO String-rawSystemProgramStdout = getProgramOutput--rawSystemProgramConf :: Verbosity  -> Program -> ProgramConfiguration-                     -> [ProgArg] -> IO ()-rawSystemProgramConf = runDbProgram--rawSystemProgramStdoutConf :: Verbosity -> Program -> ProgramConfiguration-                           -> [ProgArg] -> IO String-rawSystemProgramStdoutConf = getDbProgramOutput--type ProgramConfiguration = ProgramDb--emptyProgramConfiguration, defaultProgramConfiguration :: ProgramConfiguration-emptyProgramConfiguration   = emptyProgramDb-defaultProgramConfiguration = defaultProgramDb--restoreProgramConfiguration :: [Program] -> ProgramConfiguration-                                         -> ProgramConfiguration-restoreProgramConfiguration = restoreProgramDb--{-# DEPRECATED findProgramOnPath "use findProgramLocation instead" #-}-findProgramOnPath :: String -> Verbosity -> IO (Maybe FilePath)-findProgramOnPath = flip findProgramLocation
− Distribution/Simple/Program/Ar.hs 
@@ -1,70 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Program.Ar--- Copyright   :  Duncan Coutts 2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module provides an library interface to the @ar@ program.--module Distribution.Simple.Program.Ar (-    createArLibArchive,-    multiStageProgramInvocation,-  ) where--import Distribution.Simple.Program.Types-         ( ConfiguredProgram(..) )-import Distribution.Simple.Program.Run-         ( programInvocation, multiStageProgramInvocation-         , runProgramInvocation )-import Distribution.System-         ( OS(..), buildOS )-import Distribution.Verbosity-         ( Verbosity, deafening, verbose )---- | Call @ar@ to create a library archive from a bunch of object files.----createArLibArchive :: Verbosity -> ConfiguredProgram-                   -> FilePath -> [FilePath] -> IO ()-createArLibArchive verbosity ar target files =--  -- 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 simpleArgs  = case buildOS of-             OSX -> ["-r", "-s"]-             _   -> ["-r"]--      initialArgs = ["-q"]-      finalArgs   = case buildOS of-             OSX -> ["-q", "-s"]-             _   -> ["-q"]--      extraArgs   = verbosityOpts verbosity ++ [target]--      simple  = programInvocation ar (simpleArgs  ++ extraArgs)-      initial = programInvocation ar (initialArgs ++ extraArgs)-      middle  = initial-      final   = programInvocation ar (finalArgs   ++ extraArgs)--   in sequence_-        [ runProgramInvocation verbosity inv-        | inv <- multiStageProgramInvocation-                   simple (initial, middle, final) files ]--  where-    verbosityOpts v | v >= deafening = ["-v"]-                    | v >= verbose   = []-                    | otherwise      = ["-c"]
− Distribution/Simple/Program/Builtin.hs 
@@ -1,269 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Program.Builtin--- Copyright   :  Isaac Jones 2006, Duncan Coutts 2007-2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ 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 progams-    builtinPrograms,--    -- * Programs that Cabal knows about-    ghcProgram,-    ghcPkgProgram,-    lhcProgram,-    lhcPkgProgram,-    nhcProgram,-    hmakeProgram,-    jhcProgram,-    hugsProgram,-    ffihugsProgram,-    uhcProgram,-    gccProgram,-    ranlibProgram,-    arProgram,-    stripProgram,-    happyProgram,-    alexProgram,-    hsc2hsProgram,-    c2hsProgram,-    cpphsProgram,-    hscolourProgram,-    haddockProgram,-    greencardProgram,-    ldProgram,-    tarProgram,-    cppProgram,-    pkgConfigProgram,-    hpcProgram,-  ) where--import Distribution.Simple.Program.Types-         ( Program(..), simpleProgram )-import Distribution.Simple.Utils-         ( findProgramLocation, findProgramVersion )---- --------------------------------------------------------------- * Known programs--- ---------------------------------------------------------------- | The default list of programs.--- These programs are typically used internally to Cabal.-builtinPrograms :: [Program]-builtinPrograms =-    [-    -- compilers and related progs-      ghcProgram-    , ghcPkgProgram-    , hugsProgram-    , ffihugsProgram-    , nhcProgram-    , hmakeProgram-    , jhcProgram-    , lhcProgram-    , lhcPkgProgram-    , uhcProgram-    , hpcProgram-    -- preprocessors-    , hscolourProgram-    , haddockProgram-    , happyProgram-    , alexProgram-    , hsc2hsProgram-    , c2hsProgram-    , cpphsProgram-    , greencardProgram-    -- platform toolchain-    , gccProgram-    , ranlibProgram-    , arProgram-    , stripProgram-    , ldProgram-    , tarProgram-    -- configuration tools-    , pkgConfigProgram-    ]--ghcProgram :: Program-ghcProgram = (simpleProgram "ghc") {-    programFindVersion = findProgramVersion "--numeric-version" id-  }--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-        _               -> ""-  }--lhcProgram :: Program-lhcProgram = (simpleProgram "lhc") {-    programFindVersion = findProgramVersion "--numeric-version" id-  }--lhcPkgProgram :: Program-lhcPkgProgram = (simpleProgram "lhc-pkg") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      -- Invoking "lhc-pkg --version" gives a string like-      -- "LHC package manager version 0.7"-      case words str of-        (_:_:_:_:ver:_) -> ver-        _               -> ""-  }--nhcProgram :: Program-nhcProgram = (simpleProgram "nhc98") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      -- Invoking "nhc98 --version" gives a string like-      -- "/usr/local/bin/nhc98: v1.20 (2007-11-22)"-      case words str of-        (_:('v':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-        _         -> ""-  }--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-        _         -> ""-  }--uhcProgram :: Program-uhcProgram = (simpleProgram "uhc") {-    programFindVersion = findProgramVersion "--version-dotted" id-  }--hpcProgram :: Program-hpcProgram = (simpleProgram "hpc")-    {-        programFindVersion = findProgramVersion "version" $ \str ->-            case words str of-                (_ : _ : _ : ver : _) -> ver-                _ -> ""-    }---- AArgh! Finding the version of hugs or ffihugs is almost impossible.-hugsProgram :: Program-hugsProgram = simpleProgram "hugs"--ffihugsProgram :: Program-ffihugsProgram = simpleProgram "ffihugs"--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-        _           -> ""-  }--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 (`elem` ('.':['0'..'9'])) ver-        _           -> ""-  }--gccProgram :: Program-gccProgram = (simpleProgram "gcc") {-    programFindVersion = findProgramVersion "-dumpversion" id-  }--ranlibProgram :: Program-ranlibProgram = simpleProgram "ranlib"--arProgram :: Program-arProgram = simpleProgram "ar"--stripProgram :: Program-stripProgram = simpleProgram "strip"--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-          _           -> ""-  }--c2hsProgram :: Program-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-        _         -> ""-  }--hscolourProgram :: Program-hscolourProgram = (simpleProgram "hscolour") {-    programFindLocation = \v -> findProgramLocation v "HsColour",-    programFindVersion  = findProgramVersion "-version" $ \str ->-      -- Invoking "HsColour -version" gives a string like "HsColour 1.7"-      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-        _           -> ""-  }--greencardProgram :: Program-greencardProgram = simpleProgram "greencard"--ldProgram :: Program-ldProgram = simpleProgram "ld"--tarProgram :: Program-tarProgram = simpleProgram "tar"--cppProgram :: Program-cppProgram = simpleProgram "cpp"--pkgConfigProgram :: Program-pkgConfigProgram = (simpleProgram "pkg-config") {-    programFindVersion = findProgramVersion "--version" id-  }
− Distribution/Simple/Program/Db.hs 
@@ -1,409 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Program.Db--- Copyright   :  Isaac Jones 2006, Duncan Coutts 2007-2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This provides a 'ProgramDb' type which holds configured and not-yet--- configured programs. It is the parameter to lots of actions elsewhere in--- Cabal that need to look up and run programs. If we had a Cabal monad,--- the 'ProgramDb' would probably be a reader or state component of it.------ One nice thing about using it is that any program that is--- registered with Cabal will get some \"configure\" and \".cabal\"--- helpers like --with-foo-args --foo-path= and extra-foo-args.------ There's also a hook for adding programs in a Setup.lhs script.  See--- 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,--    -- ** Query and manipulate the program db-    addKnownProgram,-    addKnownPrograms,-    lookupKnownProgram,-    knownPrograms,-    userSpecifyPath,-    userSpecifyPaths,-    userMaybeSpecifyPath,-    userSpecifyArgs,-    userSpecifyArgss,-    userSpecifiedArgs,-    lookupProgram,-    updateProgram,--    -- ** Query and manipulate the program db-    configureProgram,-    configureAllKnownPrograms,-    reconfigurePrograms,-    requireProgram,-    requireProgramVersion,--  ) where--import Distribution.Simple.Program.Types-         ( Program(..), ProgArg, ConfiguredProgram(..), ProgramLocation(..) )-import Distribution.Simple.Program.Builtin-         ( builtinPrograms )-import Distribution.Simple.Utils-         ( die, findProgramLocation )-import Distribution.Version-         ( Version, VersionRange, isAnyVersion, withinRange )-import Distribution.Text-         ( display )-import Distribution.Verbosity-         ( Verbosity )--import Data.List-         ( foldl' )-import Data.Maybe-         ( catMaybes )-import qualified Data.Map as Map-import Control.Monad-         ( join, foldM )-import System.Directory-         ( doesFileExist )----- --------------------------------------------------------------- * Programs database--- ---------------------------------------------------------------- | The configuration is a collection of information about programs. It--- contains information both about configured programs and also about programs--- that we are yet to configure.------ The idea is that we start from a collection of unconfigured programs and one--- 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,-        configuredProgs   :: ConfiguredProgs-    }--type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg])-type UnconfiguredProgs   = Map.Map String UnconfiguredProgram-type ConfiguredProgs     = Map.Map String ConfiguredProgram---emptyProgramDb :: ProgramDb-emptyProgramDb = ProgramDb Map.empty Map.empty---defaultProgramDb :: ProgramDb-defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb----- internal helpers:-updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs)-                        -> ProgramDb -> ProgramDb-updateUnconfiguredProgs update conf =-  conf { unconfiguredProgs = update (unconfiguredProgs conf) }--updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs)-                      -> ProgramDb -> ProgramDb-updateConfiguredProgs update conf =-  conf { configuredProgs = update (configuredProgs conf) }----- Read & Show instances are based on listToFM--- Note that we only serialise the configured part of the database, this is--- because we don't need the unconfigured part after the configure stage, and--- additionally because we cannot read/show 'Program' as it contains functions.-instance Show ProgramDb where-  show = show . Map.toAscList . configuredProgs--instance Read ProgramDb where-  readsPrec p s =-    [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r)-    | (s', r) <- readsPrec p s ]----- | The Read\/Show instance does not preserve all the unconfigured 'Programs'--- because 'Program' is not in Read\/Show because it contains functions. So to--- fully restore a deserialised 'ProgramDb' use this function to add--- back all the known 'Program's.------ * 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)---addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb-addKnownPrograms progs conf = foldl' (flip addKnownProgram) conf progs---lookupKnownProgram :: String -> ProgramDb -> Maybe Program-lookupKnownProgram name =-  fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs---knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)]-knownPrograms conf =-  [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf)-           , let p' = Map.lookup (programName p) (configuredProgs conf) ]----- |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 conf     = conf-userMaybeSpecifyPath name (Just path) conf = userSpecifyPath name path conf----- |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' })----- | Like 'userSpecifyPath' but for a list of progs and their paths.----userSpecifyPaths :: [(String, FilePath)]-                 -> ProgramDb-                 -> ProgramDb-userSpecifyPaths paths conf =-  foldl' (\conf' (prog, path) -> userSpecifyPath prog path conf') conf paths----- | Like 'userSpecifyPath' but for a list of progs and their args.----userSpecifyArgss :: [(String, [ProgArg])]-                 -> ProgramDb-                 -> ProgramDb-userSpecifyArgss argss conf =-  foldl' (\conf' (prog, args) -> userSpecifyArgs prog args conf') conf 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----- | 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----- -------------------------------- Managing configured programs---- | Try to find a configured program-lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram-lookupProgram prog = Map.lookup (programName prog) . configuredProgs----- | Update a configured program in the database.-updateProgram :: ConfiguredProgram -> ProgramDb-                                   -> ProgramDb-updateProgram prog = updateConfiguredProgs $-  Map.insert (programId prog) prog----- ------------------------------ Configuring known programs---- | Try to configure a specific program. If the program is already included in--- the colleciton of unconfigured programs then we use any user-supplied--- location and arguments. If the program gets configured sucessfully 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.------ The reason for it not being a failure at this stage is that we don't know up--- front all the programs we will need, so we try to configure them all.--- To verify that a program was actually sucessfully configured use--- 'requireProgram'.----configureProgram :: Verbosity-                 -> Program-                 -> ProgramDb-                 -> IO ProgramDb-configureProgram verbosity prog conf = do-  let name = programName prog-  maybeLocation <- case userSpecifiedPath prog conf of-    Nothing   -> programFindLocation prog verbosity-             >>= return . fmap FoundOnSystem-    Just path -> do-      absolute <- doesFileExist path-      if absolute-        then return (Just (UserSpecified path))-        else findProgramLocation verbosity path-         >>= maybe (die notFound) (return . Just . UserSpecified)-      where notFound = "Cannot find the program '" ++ name ++ "' at '"-                     ++ path ++ "' or on the path"-  case maybeLocation of-    Nothing -> return conf-    Just location -> do-      version <- programFindVersion prog verbosity (locationPath location)-      let configuredProg        = ConfiguredProgram {-            programId           = name,-            programVersion      = version,-            programDefaultArgs  = [],-            programOverrideArgs = userSpecifiedArgs prog conf,-            programLocation     = location-          }-      extraArgs <- programPostConf prog verbosity configuredProg-      let configuredProg'       = configuredProg {-            programDefaultArgs  = extraArgs-          }-      return (updateConfiguredProgs (Map.insert name configuredProg') conf)----- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'.----configurePrograms :: Verbosity-                  -> [Program]-                  -> ProgramDb-                  -> IO ProgramDb-configurePrograms verbosity progs conf =-  foldM (flip (configureProgram verbosity)) conf progs----- | Try to configure all the known programs that have not yet been configured.----configureAllKnownPrograms :: Verbosity-                          -> ProgramDb-                          -> IO ProgramDb-configureAllKnownPrograms verbosity conf =-  configurePrograms verbosity-    [ prog | (prog,_,_) <- Map.elems notYetConfigured ] conf-  where-    notYetConfigured = unconfiguredProgs conf-      `Map.difference` configuredProgs conf----- | 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 paths argss conf = do-  configurePrograms verbosity progs-   . userSpecifyPaths paths-   . userSpecifyArgss argss-   $ conf--  where-    progs = catMaybes [ lookupKnownProgram name conf | (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 prog conf = do--  -- If it's not already been configured, try to configure it now-  conf' <- case lookupProgram prog conf of-    Nothing -> configureProgram verbosity prog conf-    Just _  -> return conf--  case lookupProgram prog conf' of-    Nothing             -> die notFound-    Just configuredProg -> return (configuredProg, conf')--  where notFound       = "The program " ++ programName prog-                      ++ " is required but it could not be found."----- | Check that a program is configured and available to be run.------ Additionally check that the version of the program number is suitable and--- return it. For example you could require 'AnyVersion' or--- @'orLaterVersion' ('Version' [1,0] [])@------ It raises an exception if the program could not be configured or the version--- is unsuitable, otherwise it returns the configured program and its version--- number.----requireProgramVersion :: Verbosity -> Program -> VersionRange-                      -> ProgramDb-                      -> IO (ConfiguredProgram, Version, ProgramDb)-requireProgramVersion verbosity prog range conf = do--  -- If it's not already been configured, try to configure it now-  conf' <- case lookupProgram prog conf of-    Nothing -> configureProgram verbosity prog conf-    Just _  -> return conf--  case lookupProgram prog conf' of-    Nothing                           -> die notFound-    Just configuredProg@ConfiguredProgram { programLocation = location } ->-      case programVersion configuredProg of-        Just version-          | withinRange version range -> return (configuredProg, version, conf')-          | otherwise                 -> die (badVersion version location)-        Nothing                       -> die (noVersion 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 " ++ display v-        noVersion l    = "The program "-                      ++ programName prog ++ versionRequirement-                      ++ " is required but the version of "-                      ++ locationPath l ++ " could not be determined."-        versionRequirement-          | isAnyVersion range = ""-          | otherwise          = " version " ++ display range
− Distribution/Simple/Program/HcPkg.hs 
@@ -1,338 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Program.HcPkg--- Copyright   :  Duncan Coutts 2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module provides an library interface to the @hc-pkg@ program.--- Currently only GHC and LHC have hc-pkg programs.--module Distribution.Simple.Program.HcPkg (-    register,-    reregister,-    unregister,-    expose,-    hide,-    dump,--    -- * Program invocations-    registerInvocation,-    reregisterInvocation,-    unregisterInvocation,-    exposeInvocation,-    hideInvocation,-    dumpInvocation,-  ) where--import Distribution.Package-         ( PackageId, InstalledPackageId(..) )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo, InstalledPackageInfo_(..)-         , showInstalledPackageInfo-         , emptyInstalledPackageInfo, fieldsInstalledPackageInfo )-import Distribution.ParseUtils-import Distribution.Simple.Compiler-         ( PackageDB(..), PackageDBStack )-import Distribution.Simple.Program.Types-         ( ConfiguredProgram(programId, programVersion) )-import Distribution.Simple.Program.Run-         ( ProgramInvocation(..), IOEncoding(..), programInvocation-         , runProgramInvocation, getProgramInvocationOutput )-import Distribution.Version-         ( Version(..) )-import Distribution.Text-         ( display )-import Distribution.Simple.Utils-         ( die )-import Distribution.Verbosity-         ( Verbosity, deafening, silent )-import Distribution.Compat.Exception-         ( catchExit )--import Data.Char-         ( isSpace )-import Data.Maybe-         ( fromMaybe )-import Data.List-         ( stripPrefix )-import System.FilePath as FilePath-         ( (</>), splitPath, splitDirectories, joinPath, isPathSeparator )-import qualified System.FilePath.Posix as FilePath.Posix----- | Call @hc-pkg@ to register a package.------ > hc-pkg register {filename | -} [--user | --global | --package-conf]----register :: Verbosity -> ConfiguredProgram -> PackageDBStack-         -> Either FilePath-                   InstalledPackageInfo-         -> IO ()-register verbosity hcPkg packagedb pkgFile =-  runProgramInvocation verbosity-    (registerInvocation hcPkg verbosity packagedb pkgFile)----- | Call @hc-pkg@ to re-register a package.------ > hc-pkg register {filename | -} [--user | --global | --package-conf]----reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack-           -> Either FilePath-                     InstalledPackageInfo-           -> IO ()-reregister verbosity hcPkg packagedb pkgFile =-  runProgramInvocation verbosity-    (reregisterInvocation hcPkg verbosity packagedb pkgFile)----- | Call @hc-pkg@ to unregister a package------ > hc-pkg unregister [pkgid] [--user | --global | --package-conf]----unregister :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()-unregister verbosity hcPkg packagedb pkgid =-  runProgramInvocation verbosity-    (unregisterInvocation hcPkg verbosity packagedb pkgid)----- | Call @hc-pkg@ to expose a package.------ > hc-pkg expose [pkgid] [--user | --global | --package-conf]----expose :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()-expose verbosity hcPkg packagedb pkgid =-  runProgramInvocation verbosity-    (exposeInvocation hcPkg verbosity packagedb pkgid)----- | Call @hc-pkg@ to expose a package.------ > hc-pkg expose [pkgid] [--user | --global | --package-conf]----hide :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()-hide verbosity hcPkg packagedb pkgid =-  runProgramInvocation verbosity-    (hideInvocation hcPkg verbosity packagedb pkgid)----- | Call @hc-pkg@ to get all the installed packages.----dump :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [InstalledPackageInfo]-dump verbosity hcPkg packagedb = do--  output <- getProgramInvocationOutput verbosity-              (dumpInvocation hcPkg verbosity packagedb)-    `catchExit` \_ -> die $ programId hcPkg ++ " dump failed"--  case parsePackages output of-    Left ok -> return ok-    _       -> die $ "failed to parse output of '"-                  ++ programId hcPkg ++ " dump'"--  where-    parsePackages str =-      let parsed = map parseInstalledPackageInfo' (splitPkgs str)-       in case [ msg | ParseFailed msg <- parsed ] of-            []   -> Left [   setInstalledPackageId-                           . maybe id mungePackagePaths pkgroot-                           $ pkg-                         | ParseOk _ (pkgroot, pkg) <- parsed ]-            msgs -> Right msgs--    parseInstalledPackageInfo' =-        parseFieldsFlat fields (Nothing, emptyInstalledPackageInfo)-      where-        fields =     liftFieldFst pkgrootField-               : map liftFieldSnd fieldsInstalledPackageInfo--        pkgrootField =-          simpleField "pkgroot"-            showFilePath    parseFilePathQ-            (fromMaybe "")  (\x _ -> Just x)--        liftFieldFst = liftField fst (\x (_x,y) -> (x,y))-        liftFieldSnd = liftField snd (\y (x,_y) -> (x,y))--    --TODO: this could be a lot faster. We're doing normaliseLineEndings twice-    -- and converting back and forth with lines/unlines.-    splitPkgs :: String -> [String]-    splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines-      where-        -- Handle the case of there being no packages at all.-        checkEmpty [s] | all isSpace s = []-        checkEmpty ss                  = ss--        splitWith :: (a -> Bool) -> [a] -> [[a]]-        splitWith p xs = ys : case zs of-                           []   -> []-                           _:ws -> splitWith p ws-          where (ys,zs) = break p xs--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),-      frameworkDirs     = mungePaths (frameworkDirs pkginfo),-      haddockInterfaces = mungePaths (haddockInterfaces pkginfo),-      haddockHTMLs      = mungeUrls  (haddockHTMLs pkginfo)-    }-  where-    mungePaths = map mungePath-    mungeUrls  = map mungeUrl--    mungePath p = case stripVarPrefix "${pkgroot}" p of-      Just p' -> pkgroot </> p'-      Nothing -> p--    mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of-      Just p' -> toUrlPath pkgroot p'-      Nothing -> 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-          Just [sep] | isPathSeparator sep -> Just (joinPath path')-          _                                -> Nothing-        _                                  -> Nothing----- Older installed package info files did not have the installedPackageId--- field, so if it is missing then we fill it as the source package ID.-setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo-setInstalledPackageId pkginfo@InstalledPackageInfo {-                        installedPackageId = InstalledPackageId "",-                        sourcePackageId    = pkgid-                      }-                    = pkginfo {-                        --TODO use a proper named function for the conversion-                        -- from source package id to installed package id-                        installedPackageId = InstalledPackageId (display pkgid)-                      }-setInstalledPackageId pkginfo = pkginfo-------------------------------- The program invocations-----registerInvocation, reregisterInvocation-  :: ConfiguredProgram -> Verbosity -> PackageDBStack-  -> Either FilePath InstalledPackageInfo-  -> ProgramInvocation-registerInvocation   = registerInvocation' "register"-reregisterInvocation = registerInvocation' "update"---registerInvocation' :: String-                    -> ConfiguredProgram -> Verbosity -> PackageDBStack-                    -> Either FilePath InstalledPackageInfo-                    -> ProgramInvocation-registerInvocation' cmdname hcPkg verbosity packagedbs (Left pkgFile) =-    programInvocation hcPkg args-  where-    args = [cmdname, pkgFile]-        ++ (if legacyVersion hcPkg-              then [packageDbOpts (last packagedbs)]-              else packageDbStackOpts packagedbs)-        ++ verbosityOpts hcPkg verbosity--registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) =-    (programInvocation hcPkg args) {-      progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),-      progInvokeInputEncoding = IOEncodingUTF8-    }-  where-    args = [cmdname, "-"]-        ++ (if legacyVersion hcPkg-              then [packageDbOpts (last packagedbs)]-              else packageDbStackOpts packagedbs)-        ++ verbosityOpts hcPkg verbosity---unregisterInvocation :: ConfiguredProgram-                     -> Verbosity -> PackageDB -> PackageId-                     -> ProgramInvocation-unregisterInvocation hcPkg verbosity packagedb pkgid =-  programInvocation hcPkg $-       ["unregister", packageDbOpts packagedb, display pkgid]-    ++ verbosityOpts hcPkg verbosity---exposeInvocation :: ConfiguredProgram-                 -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation-exposeInvocation hcPkg verbosity packagedb pkgid =-  programInvocation hcPkg $-       ["expose", packageDbOpts packagedb, display pkgid]-    ++ verbosityOpts hcPkg verbosity---hideInvocation :: ConfiguredProgram-               -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation-hideInvocation hcPkg verbosity packagedb pkgid =-  programInvocation hcPkg $-       ["hide", packageDbOpts packagedb, display pkgid]-    ++ verbosityOpts hcPkg verbosity---dumpInvocation :: ConfiguredProgram-               -> Verbosity -> PackageDB -> ProgramInvocation-dumpInvocation hcPkg _verbosity packagedb =-    (programInvocation hcPkg args) {-      progInvokeOutputEncoding = IOEncodingUTF8-    }-  where-    args = ["dump", packageDbOpts packagedb]-        ++ verbosityOpts hcPkg silent-           -- We use verbosity level 'silent' because it is important that we-           -- do not contaminate the output with info/debug messages.---packageDbStackOpts :: PackageDBStack -> [String]-packageDbStackOpts dbstack = case dbstack of-  (GlobalPackageDB:UserPackageDB:dbs) -> "--global"-                                       : "--user"-                                       : map specific dbs-  (GlobalPackageDB:dbs)               -> "--global"-                                       : "--no-user-package-conf"-                                       : map specific dbs-  _                                   -> ierror-  where-    specific (SpecificPackageDB db) = "--package-conf=" ++ db-    specific _ = ierror-    ierror :: a-    ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)--packageDbOpts :: PackageDB -> String-packageDbOpts GlobalPackageDB        = "--global"-packageDbOpts UserPackageDB          = "--user"-packageDbOpts (SpecificPackageDB db) = "--package-conf=" ++ db--verbosityOpts :: ConfiguredProgram -> Verbosity -> [String]-verbosityOpts hcPkg v--  -- ghc-pkg < 6.11 does not support -v-  | programId hcPkg == "ghc-pkg"- && programVersion hcPkg < Just (Version [6,11] [])-                   = []--  | v >= deafening = ["-v2"]-  | v == silent    = ["-v0"]-  | otherwise      = []---- Handle quirks in ghc-pkg 6.8 and older-legacyVersion :: ConfiguredProgram -> Bool-legacyVersion hcPkg = programId hcPkg == "ghc-pkg"-                   && programVersion hcPkg < Just (Version [6,9] [])
− Distribution/Simple/Program/Hpc.hs 
@@ -1,73 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Program.Hpc--- Copyright   :  Thomas Tuegel 2011------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module provides an library interface to the @hpc@ program.--module Distribution.Simple.Program.Hpc-    ( markup-    , union-    ) where--import Distribution.ModuleName ( ModuleName )-import Distribution.Simple.Program.Run-         ( ProgramInvocation, programInvocation, runProgramInvocation )-import Distribution.Simple.Program.Types ( ConfiguredProgram )-import Distribution.Text ( display )-import Distribution.Verbosity ( Verbosity )--markup :: ConfiguredProgram-       -> Verbosity-       -> FilePath            -- ^ Path to .tix file-       -> FilePath            -- ^ Path to directory with .mix files-       -> FilePath            -- ^ Path where html output should be located-       -> [ModuleName]        -- ^ List of modules to exclude from report-       -> IO ()-markup hpc verbosity tixFile hpcDir destDir excluded =-    runProgramInvocation verbosity-      (markupInvocation hpc tixFile hpcDir destDir excluded)--markupInvocation :: ConfiguredProgram-                 -> FilePath            -- ^ Path to .tix file-                 -> FilePath            -- ^ Path to directory with .mix files-                 -> FilePath            -- ^ Path where html output should be-                                        -- located-                 -> [ModuleName]        -- ^ List of modules to exclude from-                                        -- report-                 -> ProgramInvocation-markupInvocation hpc tixFile hpcDir destDir excluded =-    let args = [ "markup", tixFile-               , "--hpcdir=" ++ hpcDir-               , "--destdir=" ++ destDir-               ]-            ++ ["--exclude=" ++ display moduleName-               | moduleName <- excluded ]-    in programInvocation hpc args--union :: ConfiguredProgram-      -> Verbosity-      -> [FilePath]         -- ^ Paths to .tix files-      -> FilePath           -- ^ Path to resultant .tix file-      -> [ModuleName]       -- ^ List of modules to exclude from union-      -> IO ()-union hpc verbosity tixFiles outFile excluded =-    runProgramInvocation verbosity-      (unionInvocation hpc tixFiles outFile excluded)--unionInvocation :: ConfiguredProgram-                -> [FilePath]       -- ^ Paths to .tix files-                -> FilePath         -- ^ Path to resultant .tix file-                -> [ModuleName]     -- ^ List of modules to exclude from union-                -> ProgramInvocation-unionInvocation hpc tixFiles outFile excluded =-    programInvocation hpc $ concat-        [ ["sum", "--union"]-        , tixFiles-        , ["--output=" ++ outFile]-        , ["--exclude=" ++ display moduleName-          | moduleName <- excluded ]-        ]
− Distribution/Simple/Program/Ld.hs 
@@ -1,62 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Program.Ld--- Copyright   :  Duncan Coutts 2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module provides an library interface to the @ld@ linker program.--module Distribution.Simple.Program.Ld (-    combineObjectFiles,-  ) where--import Distribution.Simple.Program.Types-         ( ConfiguredProgram(..) )-import Distribution.Simple.Program.Run-         ( programInvocation, multiStageProgramInvocation-         , runProgramInvocation )-import Distribution.Verbosity-         ( Verbosity )--import System.Directory-         ( renameFile )-import System.FilePath-         ( (<.>) )---- | Call @ld -r@ to link a bunch of object files together.----combineObjectFiles :: Verbosity -> ConfiguredProgram-                   -> FilePath -> [FilePath] -> IO ()-combineObjectFiles verbosity ld target files =--  -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is,-  -- if we have more object files than fit on a single command line then we-  -- have a slight problem. What we have to do is link files in batches into-  -- a temp object file and then include that one in the next batch.--  let simpleArgs  = ["-r", "-o", target]--      initialArgs = ["-r", "-o", target]-      middleArgs  = ["-r", "-o", target, tmpfile]-      finalArgs   = middleArgs--      simple      = programInvocation ld simpleArgs-      initial     = programInvocation ld initialArgs-      middle      = programInvocation ld middleArgs-      final       = programInvocation ld finalArgs--      invocations = multiStageProgramInvocation-                      simple (initial, middle, final) files--   in run invocations--  where-    tmpfile        = target <.> "tmp" -- perhaps should use a proper temp file--    run []         = return ()-    run [inv]      = runProgramInvocation verbosity inv-    run (inv:invs) = do runProgramInvocation verbosity inv-                        renameFile target tmpfile-                        run invs
− Distribution/Simple/Program/Run.hs 
@@ -1,218 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Program.Run--- Copyright   :  Duncan Coutts 2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ 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,--  ) where--import Distribution.Simple.Program.Types-         ( ConfiguredProgram(..), programPath )-import Distribution.Simple.Utils-         ( die, rawSystemExit, rawSystemStdInOut-         , toUTF8, fromUTF8, normaliseLineEndings )-import Distribution.Verbosity-         ( Verbosity )--import Data.List-         ( foldl', unfoldr )-import Control.Monad-         ( when )-import System.Exit-         ( ExitCode(..) )---- | Represents a specific invocation of a specific program.------ This is used as an intermediate type between deciding how to call a program--- 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, String)],-       progInvokeCwd   :: Maybe FilePath,-       progInvokeInput :: Maybe String,-       progInvokeInputEncoding  :: IOEncoding,-       progInvokeOutputEncoding :: IOEncoding-     }--data IOEncoding = IOEncodingText   -- locale mode text-                | IOEncodingUTF8   -- always utf8--emptyProgramInvocation :: ProgramInvocation-emptyProgramInvocation =-  ProgramInvocation {-    progInvokePath  = "",-    progInvokeArgs  = [],-    progInvokeEnv   = [],-    progInvokeCwd   = Nothing,-    progInvokeInput = Nothing,-    progInvokeInputEncoding  = IOEncodingText,-    progInvokeOutputEncoding = IOEncodingText-  }--simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation-simpleProgramInvocation path args =-  emptyProgramInvocation {-    progInvokePath  = path,-    progInvokeArgs  = args-  }--programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation-programInvocation prog args =-  emptyProgramInvocation {-    progInvokePath = programPath prog,-    progInvokeArgs = programDefaultArgs prog-                  ++ args-                  ++ programOverrideArgs prog-  }---runProgramInvocation :: Verbosity -> ProgramInvocation -> IO ()-runProgramInvocation verbosity-  ProgramInvocation {-    progInvokePath  = path,-    progInvokeArgs  = args,-    progInvokeEnv   = [],-    progInvokeCwd   = Nothing,-    progInvokeInput = Nothing-  } =-  rawSystemExit verbosity path args--runProgramInvocation verbosity-  ProgramInvocation {-    progInvokePath  = path,-    progInvokeArgs  = args,-    progInvokeEnv   = [],-    progInvokeCwd   = Nothing,-    progInvokeInput = Just inputStr,-    progInvokeInputEncoding = encoding-  } = do-    (_, errors, exitCode) <- rawSystemStdInOut verbosity-                                    path args-                                    (Just input) False-    when (exitCode /= ExitSuccess) $-      die errors-  where-    input = case encoding of-              IOEncodingText -> (inputStr, False)-              IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8--runProgramInvocation _ _ =-   die "runProgramInvocation: not yet implemented for this form of invocation"---getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String-getProgramInvocationOutput verbosity-  ProgramInvocation {-    progInvokePath  = path,-    progInvokeArgs  = args,-    progInvokeEnv   = [],-    progInvokeCwd   = Nothing,-    progInvokeInput = Nothing,-    progInvokeOutputEncoding = encoding-  } = do-  let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False-      decode | utf8      = fromUTF8 . normaliseLineEndings-             | otherwise = id-  (output, errors, exitCode) <- rawSystemStdInOut verbosity-                                  path args-                                  Nothing utf8-  when (exitCode /= ExitSuccess) $-    die errors-  return (decode output)---getProgramInvocationOutput _ _ =-   die "getProgramInvocationOutput: not yet implemented for this form of invocation"----- | 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.------ It takes four template invocations corresponding to the simple, initial,--- middle and last invocations. If the number of args given is small enough--- that we can get away with just a single invocation then the simple one is--- used:------ > $ simple args------ If the number of args given means that we need to use multiple invocations--- then the templates for the initial, middle and last invocations are used:------ > $ initial args_0--- > $ middle  args_1--- > $ 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)-      fixedArgSize = maximum (map argSize [simple, initial, middle, final])-      chunkSize    = maxCommandLineSize - fixedArgSize--   in case splitChunks chunkSize args of-        []     -> [ simple ]--        [c]    -> [ simple  `appendArgs` c ]--        [c,c'] -> [ initial `appendArgs` c ]-               ++ [ final   `appendArgs` c']--        (c:cs) -> [ initial `appendArgs` c ]-               ++ [ middle  `appendArgs` c'| c' <- init cs ]-               ++ [ final   `appendArgs` c'| let c' = last cs ]--  where-    inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as }--    splitChunks len = unfoldr $ \s ->-      if null s then Nothing-                else Just (chunk len s)--    chunk len (s:_) | length s >= len = error toolong-    chunk len ss    = chunk' [] len ss--    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--    toolong = "multiStageProgramInvocation: a single program arg is larger "-           ++ "than the maximum command line length!"-----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----maxCommandLineSize :: Int-maxCommandLineSize = 30 * 1024
− Distribution/Simple/Program/Script.hs 
@@ -1,105 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Program.Script--- Copyright   :  Duncan Coutts 2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ 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,-  ) where--import Distribution.Simple.Program.Run-         ( ProgramInvocation(..) )-import Distribution.System-         ( OS(..) )--import Data.Maybe-         ( maybeToList )---- | 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----- | 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" ]-       ++ [ "export " ++ var ++ "=" ++ quote val-          | (var,val) <- envExtra ]-       ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ]-       ++ [ (case minput of-              Nothing    -> ""-              Just input -> "echo " ++ quote input ++ " | ")-         ++ unwords (map quote $ path : args) ++ " \"$@\""]--  where-    quote :: String -> String-    quote s = "'" ++ escape s ++ "'"--    escape []        = []-    escape ('\'':cs) = "'\\''" ++ escape cs-    escape (c   :cs) = c        : escape cs----- | 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" ]-       ++ [ "set " ++ var ++ "=" ++ escape val | (var,val) <- envExtra ]-       ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ]-       ++ case minput of-            Nothing    ->-                [ path ++ concatMap (' ':) args ]--            Just input ->-                [ "(" ]-             ++ [ "echo " ++ escape line | line <- lines input ]-             ++ [ ") | "-               ++ "\"" ++ path ++ "\""-               ++ concatMap (\arg -> ' ':quote arg) args ]--  where-    quote :: String -> String-    quote s = "\"" ++ escapeQ s ++ "\""--    escapeQ []       = []-    escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs-    escapeQ (c  :cs) = c         : escapeQ cs--    escape []        = []-    escape ('|':cs) = "^|" ++ escape cs-    escape ('<':cs) = "^<" ++ escape cs-    escape ('>':cs) = "^>" ++ escape cs-    escape ('&':cs) = "^&" ++ escape cs-    escape ('(':cs) = "^(" ++ escape cs-    escape (')':cs) = "^)" ++ escape cs-    escape ('^':cs) = "^^" ++ escape cs-    escape (c  :cs) = c     : escape cs
− Distribution/Simple/Program/Types.hs 
@@ -1,130 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Program.Types--- Copyright   :  Isaac Jones 2006, Duncan Coutts 2007-2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This provides an abstraction which deals with configuring and running--- programs. A 'Program' is a static notion of a known program. A--- 'ConfiguredProgram' is a 'Program' that has been found on the current--- machine and is ready to be run (possibly with some user-supplied default--- 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(..),-    simpleProgram,--    -- * Configured program and related functions-    ConfiguredProgram(..),-    programPath,-    ProgArg,-    ProgramLocation(..),-    simpleConfiguredProgram,-  ) where--import Distribution.Simple.Utils-         ( findProgramLocation )-import Distribution.Version-         ( Version )-import Distribution.Verbosity-         ( Verbosity )---- | Represents a program which can be configured.------ 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 it's location was not-       -- specified by the user. Usually this will just be a-       programFindLocation :: Verbosity -> IO (Maybe FilePath),--       -- | Try to find the version of the program. For many programs this is-       -- not possible or is not necessary so it's ok to return Nothing.-       programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version),--       -- | A function to do any additional configuration after we have-       -- located the program (and perhaps identified its version). It is-       -- allowed to return additional flags that will be passed to the-       -- program on every invocation.-       programPostConf :: Verbosity -> ConfiguredProgram -> IO [ProgArg]-     }--type ProgArg = String---- | 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 {-       -- | 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],--       -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@-       programLocation :: ProgramLocation-     } deriving (Read, Show, Eq)---- | Where a program was found. Also tells us whether it's specifed 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 (Read, Show, Eq)---- | The full path of a configured program.-programPath :: ConfiguredProgram -> FilePath-programPath = locationPath . programLocation---- | 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   -> findProgramLocation v name,-    programFindVersion  = \_ _ -> return Nothing,-    programPostConf     = \_ _ -> return []-  }---- | Make a simple 'ConfiguredProgram'.------ > simpleConfiguredProgram "foo" (FoundOnSystem path)----simpleConfiguredProgram :: String -> ProgramLocation -> ConfiguredProgram-simpleConfiguredProgram name loc = ConfiguredProgram {-     programId           = name,-     programVersion      = Nothing,-     programDefaultArgs  = [],-     programOverrideArgs = [],-     programLocation     = loc-  }
− Distribution/Simple/Register.hs 
@@ -1,390 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Register--- Copyright   :  Isaac Jones 2003-2004------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module deals with registering and unregistering packages. There are a--- couple ways it can do this, one is to do it directly. Another is to generate--- a script that can be run later to do it. The idea here being that the user--- is shielded from the details of what command to use for package registration--- for a particular compiler. In practice this aspect was not especially--- popular so we also provide a way to simply generate the package registration--- file which then must be manually passed to @ghc-pkg@. It is possible to--- generate registration information for where the package is to be installed,--- or alternatively to register the package inplace in the build tree. The--- latter is occasionally handy, and will become more important when we try to--- build multi-package systems.------ This module does not delegate anything to the per-compiler modules but just--- mixes it all in in this module, which is rather unsatisfactory. The script--- generation and the unregister feature are not well used or tested.--{- Copyright (c) 2003-2004, Isaac Jones-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.Register (-    register,-    unregister,--    registerPackage,-    generateRegistrationInfo,-    inplaceInstalledPackageInfo,-    absoluteInstalledPackageInfo,-    generalInstalledPackageInfo,-  ) where--import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-         , InstallDirs(..), absoluteInstallDirs )-import Distribution.Simple.BuildPaths (haddockName)-import qualified Distribution.Simple.GHC  as GHC-import qualified Distribution.Simple.LHC  as LHC-import qualified Distribution.Simple.Hugs as Hugs-import qualified Distribution.Simple.UHC  as UHC-import Distribution.Simple.Compiler-         ( compilerVersion, CompilerFlavor(..), compilerFlavor-         , PackageDBStack, registrationPackageDB )-import Distribution.Simple.Program-         ( ConfiguredProgram, runProgramInvocation-         , requireProgram, lookupProgram, ghcPkgProgram, lhcPkgProgram )-import Distribution.Simple.Program.Script-         ( invocationAsSystemScript )-import qualified Distribution.Simple.Program.HcPkg as HcPkg-import Distribution.Simple.Setup-         ( RegisterFlags(..), CopyDest(..)-         , fromFlag, fromFlagOrDefault, flagToMaybe )-import Distribution.PackageDescription-         ( PackageDescription(..), Library(..), BuildInfo(..), hcOptions )-import Distribution.Package-         ( Package(..), packageName, InstalledPackageId(..) )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo, InstalledPackageInfo_(InstalledPackageInfo)-         , showInstalledPackageInfo )-import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.Simple.Utils-         ( writeUTF8File, writeFileAtomic, setFileExecutable-         , die, notice, setupMessage )-import Distribution.System-         ( OS(..), buildOS )-import Distribution.Text-         ( display )-import Distribution.Version ( Version(..) )-import Distribution.Verbosity as Verbosity-         ( Verbosity, normal )-import Distribution.Compat.Exception-         ( tryIO )--import System.FilePath ((</>), (<.>), isAbsolute)-import System.Directory-         ( getCurrentDirectory, removeDirectoryRecursive )--import Data.Maybe-         ( isJust, fromMaybe, maybeToList )-import Data.List-         ( partition, nub )----- -------------------------------------------------------------------------------- Registration--register :: PackageDescription -> LocalBuildInfo-         -> RegisterFlags -- ^Install in the user's database?; verbose-         -> IO ()-register pkg@PackageDescription { library       = Just lib  }-         lbi@LocalBuildInfo     { libraryConfig = Just clbi } regFlags-  = do--    installedPkgInfo <- generateRegistrationInfo-                           verbosity pkg lib lbi clbi inplace distPref--     -- Three different modes:-    case () of-     _ | modeGenerateRegFile   -> writeRegistrationFile installedPkgInfo-       | modeGenerateRegScript -> writeRegisterScript   installedPkgInfo-       | otherwise             -> registerPackage verbosity-                                    installedPkgInfo pkg lbi inplace packageDbs--  where-    modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))-    regFile             = fromMaybe (display (packageId pkg) <.> "conf")-                                    (fromFlag (regGenPkgConf regFlags))--    modeGenerateRegScript = fromFlag (regGenScript regFlags)--    inplace   = fromFlag (regInPlace 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))-    distPref  = fromFlag (regDistPref regFlags)-    verbosity = fromFlag (regVerbosity regFlags)--    writeRegistrationFile installedPkgInfo = do-      notice verbosity ("Creating package registration file: " ++ regFile)-      writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo)--    writeRegisterScript installedPkgInfo =-      case compilerFlavor (compiler lbi) of-        GHC  -> do (ghcPkg, _) <- requireProgram verbosity ghcPkgProgram (withPrograms lbi)-                   writeHcPkgRegisterScript verbosity installedPkgInfo ghcPkg packageDbs-        LHC  -> do (lhcPkg, _) <- requireProgram verbosity lhcPkgProgram (withPrograms lbi)-                   writeHcPkgRegisterScript verbosity installedPkgInfo lhcPkg packageDbs-        Hugs -> notice verbosity "Registration scripts not needed for hugs"-        JHC  -> notice verbosity "Registration scripts not needed for jhc"-        NHC  -> notice verbosity "Registration scripts not needed for nhc98"-        UHC  -> notice verbosity "Registration scripts not needed for uhc"-        _    -> die "Registration scripts are not implemented for this compiler"--register _ _ regFlags = notice verbosity "No package to register"-  where-    verbosity = fromFlag (regVerbosity regFlags)---generateRegistrationInfo :: Verbosity-                         -> PackageDescription-                         -> Library-                         -> LocalBuildInfo-                         -> ComponentLocalBuildInfo-                         -> Bool-                         -> FilePath-                         -> IO InstalledPackageInfo-generateRegistrationInfo verbosity pkg lib lbi clbi inplace distPref = do-  --TODO: eliminate pwd!-  pwd <- getCurrentDirectory--  --TODO: the method of setting the InstalledPackageId is compiler specific-  --      this aspect should be delegated to a per-compiler helper.-  let comp = compiler lbi-  ipid <--    case compilerFlavor comp of-     GHC | compilerVersion comp >= Version [6,11] [] -> do-            s <- GHC.libAbiHash verbosity pkg lbi lib clbi-            return (InstalledPackageId (display (packageId pkg) ++ '-':s))-     _other -> do-            return (InstalledPackageId (display (packageId pkg)))--  let installedPkgInfo-        | inplace   = inplaceInstalledPackageInfo pwd distPref-                        pkg lib lbi clbi-        | otherwise = absoluteInstalledPackageInfo-                        pkg lib lbi clbi--  return installedPkgInfo{ IPI.installedPackageId = ipid }---registerPackage :: Verbosity-                -> InstalledPackageInfo-                -> PackageDescription-                -> LocalBuildInfo-                -> Bool-                -> PackageDBStack-                -> IO ()-registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do-  setupMessage verbosity "Registering" (packageId pkg)-  case compilerFlavor (compiler lbi) of-    GHC  -> GHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs-    LHC  -> LHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs-    Hugs -> Hugs.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs-    UHC  -> UHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs-    JHC  -> notice verbosity "Registering for jhc (nothing to do)"-    NHC  -> notice verbosity "Registering for nhc98 (nothing to do)"-    _    -> die "Registering is not implemented for this compiler"---writeHcPkgRegisterScript :: Verbosity-                         -> InstalledPackageInfo-                         -> ConfiguredProgram-                         -> PackageDBStack-                         -> IO ()-writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDbs = do-  let invocation  = HcPkg.reregisterInvocation hcPkg Verbosity.normal-                      packageDbs (Right installedPkgInfo)-      regScript   = invocationAsSystemScript buildOS   invocation--  notice verbosity ("Creating package registration script: " ++ regScriptFileName)-  writeUTF8File regScriptFileName regScript-  setFileExecutable regScriptFileName--regScriptFileName :: FilePath-regScriptFileName = case buildOS of-                        Windows -> "register.bat"-                        _       -> "register.sh"----- -------------------------------------------------------------------------------- Making the InstalledPackageInfo---- | Construct 'InstalledPackageInfo' for a library in a package, given a set--- of installation directories.----generalInstalledPackageInfo-  :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to-                                -- absolute paths.-  -> PackageDescription-  -> Library-  -> ComponentLocalBuildInfo-  -> InstallDirs FilePath-  -> InstalledPackageInfo-generalInstalledPackageInfo adjustRelIncDirs pkg lib clbi installDirs =-  InstalledPackageInfo {-    --TODO: do not open-code this conversion from PackageId to InstalledPackageId-    IPI.installedPackageId = InstalledPackageId (display (packageId pkg)),-    IPI.sourcePackageId    = packageId   pkg,-    IPI.license            = license     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.exposed            = libExposed  lib,-    IPI.exposedModules     = exposedModules lib,-    IPI.hiddenModules      = otherModules bi,-    IPI.trusted            = IPI.trusted IPI.emptyInstalledPackageInfo,-    IPI.importDirs         = [ libdir installDirs | hasModules ],-    IPI.libraryDirs        = if hasLibrary-                               then libdir installDirs : extraLibDirs bi-                               else                      extraLibDirs bi,-    IPI.hsLibraries        = [ "HS" ++ display (packageId pkg) | hasLibrary ],-    IPI.extraLibraries     = extraLibs bi,-    IPI.extraGHCiLibraries = [],-    IPI.includeDirs        = absinc ++ adjustRelIncDirs relinc,-    IPI.includes           = includes bi,-    IPI.depends            = map fst (componentPackageDeps clbi),-    IPI.hugsOptions        = hcOptions Hugs bi,-    IPI.ccOptions          = [], -- Note. NOT ccOptions bi!-                                 -- We don't want cc-options to be propagated-                                 -- to C compilations in other packages.-    IPI.ldOptions          = ldOptions bi,-    IPI.frameworkDirs      = [],-    IPI.frameworks         = frameworks bi,-    IPI.haddockInterfaces  = [haddockdir installDirs </> haddockName pkg],-    IPI.haddockHTMLs       = [htmldir installDirs]-  }-  where-    bi = libBuildInfo lib-    (absinc, relinc) = partition isAbsolute (includeDirs bi)-    hasModules = not $ null (exposedModules lib)-                    && null (otherModules bi)-    hasLibrary = hasModules || not (null (cSources bi))----- | Construct 'InstalledPackageInfo' for a library that is inplace in the--- build tree.------ This function knows about the layout of inplace packages.----inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree-                            -> FilePath -- ^ location of the dist tree-                            -> PackageDescription-                            -> Library-                            -> LocalBuildInfo-                            -> ComponentLocalBuildInfo-                            -> InstalledPackageInfo-inplaceInstalledPackageInfo inplaceDir distPref pkg lib lbi clbi =-    generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib clbi installDirs-  where-    adjustReativeIncludeDirs = map (inplaceDir </>)-    installDirs =-      (absoluteInstallDirs pkg lbi NoCopyDest) {-        libdir     = inplaceDir </> buildDir lbi,-        datadir    = inplaceDir,-        datasubdir = distPref,-        docdir     = inplaceDocdir,-        htmldir    = inplaceHtmldir,-        haddockdir = inplaceHtmldir-      }-    inplaceDocdir  = inplaceDir </> distPref </> "doc"-    inplaceHtmldir = inplaceDocdir </> "html" </> display (packageName pkg)----- | Construct 'InstalledPackageInfo' for the final install location of a--- library package.------ This function knows about the layout of installed packages.----absoluteInstalledPackageInfo :: PackageDescription-                             -> Library-                             -> LocalBuildInfo-                             -> ComponentLocalBuildInfo-                             -> InstalledPackageInfo-absoluteInstalledPackageInfo pkg lib lbi clbi =-    generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib 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]-    bi = libBuildInfo lib-    installDirs = absoluteInstallDirs pkg lbi NoCopyDest---- -------------------------------------------------------------------------------- Unregistration--unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()-unregister pkg lbi regFlags = do-  let pkgid     = packageId pkg-      genScript = fromFlag (regGenScript regFlags)-      verbosity = fromFlag (regVerbosity regFlags)-      packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi))-                                    (regPackageDB regFlags)-      installDirs = absoluteInstallDirs pkg lbi NoCopyDest-  setupMessage verbosity "Unregistering" pkgid-  case compilerFlavor (compiler lbi) of-    GHC ->-      let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)-          invocation = HcPkg.unregisterInvocation ghcPkg Verbosity.normal-                         packageDb pkgid-      in if genScript-           then writeFileAtomic unregScriptFileName-                  (invocationAsSystemScript buildOS invocation)-            else runProgramInvocation verbosity invocation-    Hugs -> do-        _ <- tryIO $ removeDirectoryRecursive (libdir installDirs)-        return ()-    NHC -> do-        _ <- tryIO $ removeDirectoryRecursive (libdir installDirs)-        return ()-    _ ->-        die ("only unregistering with GHC and Hugs is implemented")--unregScriptFileName :: FilePath-unregScriptFileName = case buildOS of-                          Windows -> "unregister.bat"-                          _       -> "unregister.sh"
− Distribution/Simple/Setup.hs 
@@ -1,1665 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Setup--- Copyright   :  Isaac Jones 2003-2004---                Duncan Coutts 2007------ 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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.Setup (--  GlobalFlags(..),   emptyGlobalFlags,   defaultGlobalFlags,   globalCommand,-  ConfigFlags(..),   emptyConfigFlags,   defaultConfigFlags,   configureCommand,-  CopyFlags(..),     emptyCopyFlags,     defaultCopyFlags,     copyCommand,-  InstallFlags(..),  emptyInstallFlags,  defaultInstallFlags,  installCommand,-  HaddockFlags(..),  emptyHaddockFlags,  defaultHaddockFlags,  haddockCommand,-  HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,-  BuildFlags(..),    emptyBuildFlags,    defaultBuildFlags,    buildCommand,-  buildVerbose,-  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,-  installDirsOptions,--  defaultDistPref,--  Flag(..),-  toFlag,-  fromFlag,-  fromFlagOrDefault,-  flagToMaybe,-  flagToList,-  boolOpt, boolOpt', trueArg, falseArg, optionVerbosity ) where--import Distribution.Compiler ()-import Distribution.ReadE-import Distribution.Text-         ( Text(..), display )-import qualified Distribution.Compat.ReadP as Parse-import qualified Text.PrettyPrint as Disp-import Distribution.Package ( Dependency(..) )-import Distribution.PackageDescription-         ( FlagName(..), FlagAssignment )-import Distribution.Simple.Command hiding (boolOpt, boolOpt')-import qualified Distribution.Simple.Command as Command-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..)-         , OptimisationLevel(..), flagToOptimisationLevel )-import Distribution.Simple.Utils-         ( wrapLine, lowercase, intercalate )-import Distribution.Simple.Program (Program(..), ProgramConfiguration,-                             requireProgram,-                             programInvocation, progInvokePath, progInvokeArgs,-                             knownPrograms,-                             addKnownProgram, emptyProgramConfiguration,-                             haddockProgram, ghcProgram, gccProgram, ldProgram)-import Distribution.Simple.InstallDirs-         ( InstallDirs(..), CopyDest(..),-           PathTemplate, toPathTemplate, fromPathTemplate )-import Distribution.Verbosity--import Data.List   ( sort )-import Data.Char   ( isSpace, isAlpha )-import Data.Monoid ( Monoid(..) )---- FIXME Not sure where this should live-defaultDistPref :: FilePath-defaultDistPref = "dist"---- --------------------------------------------------------------- * Flag type--- ---------------------------------------------------------------- | All flags are monoids, they come in two flavours:------ 1. list flags eg------ > --ghc-option=foo --ghc-option=bar------ gives us all the values ["foo", "bar"]------ 2. singular value flags, eg:------ > --enable-foo --disable-foo------ 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 (Show, Read, Eq)--instance Functor Flag where-  fmap f (Flag x) = Flag (f x)-  fmap _ NoFlag  = NoFlag--instance Monoid (Flag a) where-  mempty = NoFlag-  _ `mappend` f@(Flag _) = f-  f `mappend` NoFlag    = f--instance Bounded a => Bounded (Flag a) where-  minBound = toFlag minBound-  maxBound = toFlag maxBound--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 _        _        _        = []--toFlag :: a -> Flag a-toFlag = Flag--fromFlag :: Flag a -> a-fromFlag (Flag x) = x-fromFlag NoFlag   = error "fromFlag NoFlag. Use fromFlagOrDefault"--fromFlagOrDefault :: a -> Flag a -> a-fromFlagOrDefault _   (Flag x) = x-fromFlagOrDefault def NoFlag   = def--flagToMaybe :: Flag a -> Maybe a-flagToMaybe (Flag x) = Just x-flagToMaybe NoFlag   = Nothing--flagToList :: Flag a -> [a]-flagToList (Flag x) = [x]-flagToList NoFlag   = []---- --------------------------------------------------------------- * 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-  }--defaultGlobalFlags :: GlobalFlags-defaultGlobalFlags  = GlobalFlags {-    globalVersion        = Flag False,-    globalNumericVersion = Flag False-  }--globalCommand :: CommandUI GlobalFlags-globalCommand = CommandUI {-    commandName         = "",-    commandSynopsis     = "",-    commandUsage        = \_ ->-         "This Setup program uses the Haskell Cabal Infrastructure.\n"-      ++ "See http://www.haskell.org/cabal/ for more information.\n",-    commandDescription  = Just $ \pname ->-         "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"]],-    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 = GlobalFlags {-    globalVersion        = mempty,-    globalNumericVersion = mempty-  }-  mappend a b = GlobalFlags {-    globalVersion        = combine globalVersion,-    globalNumericVersion = combine globalNumericVersion-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Config flags--- ---------------------------------------------------------------- | Flags to @configure@ command-data ConfigFlags = ConfigFlags {-    --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-    -- ProgramConfiguration directly and not via ConfigFlags-    configPrograms      :: ProgramConfiguration, -- ^All programs that cabal may run--    configProgramPaths  :: [(String, FilePath)], -- ^user specifed programs paths-    configProgramArgs   :: [(String, [String])], -- ^user specifed programs args-    configHcFlavor      :: Flag CompilerFlavor, -- ^The \"flavor\" of the compiler, sugh as GHC or Hugs.-    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-    configDynExe        :: Flag Bool,     -- ^Enable dynamic linking of the executables.-    configProfExe       :: Flag Bool,     -- ^Enable profiling in the executables.-    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-    configExtraIncludeDirs :: [FilePath],   -- ^ path to search for header files--    configDistPref :: Flag FilePath, -- ^"dist" prefix-    configVerbosity :: Flag Verbosity, -- ^verbosity level-    configUserInstall :: Flag Bool,    -- ^The --user\/--global flag-    configPackageDB :: Flag PackageDB, -- ^Which package DB to use-    configGHCiLib   :: Flag Bool,      -- ^Enable compiling library for GHCi-    configSplitObjs :: Flag Bool,      -- ^Enable -split-objs with GHC-    configStripExes :: Flag Bool,      -- ^Enable executable stripping-    configConstraints :: [Dependency], -- ^Additional constraints for-                                       -- dependencies-    configConfigurationsFlags :: FlagAssignment,-    configTests :: Flag Bool,     -- ^Enable test suite compilation-    configBenchmarks :: Flag Bool,     -- ^Enable benchmark compilation-    configLibCoverage :: Flag Bool    -- ^ Enable test suite program coverage-  }-  deriving (Read,Show)--defaultConfigFlags :: ProgramConfiguration -> ConfigFlags-defaultConfigFlags progConf = emptyConfigFlags {-    configPrograms     = progConf,-    configHcFlavor     = maybe NoFlag Flag defaultCompilerFlavor,-    configVanillaLib   = Flag True,-    configProfLib      = Flag False,-    configSharedLib    = Flag False,-    configDynExe       = Flag False,-    configProfExe      = Flag False,-    configOptimization = Flag NormalOptimisation,-    configProgPrefix   = Flag (toPathTemplate ""),-    configProgSuffix   = Flag (toPathTemplate ""),-    configDistPref     = Flag defaultDistPref,-    configVerbosity    = Flag normal,-    configUserInstall  = Flag False,           --TODO: reverse this-    configGHCiLib      = Flag True,-    configSplitObjs    = Flag False, -- takes longer, so turn off by default-    configStripExes    = Flag True,-    configTests  = Flag False,-    configBenchmarks   = Flag False,-    configLibCoverage = Flag False-  }--configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags-configureCommand progConf = makeCommand name shortDesc longDesc defaultFlags options-  where-    name       = "configure"-    shortDesc  = "Prepare to build the package."-    longDesc   = Just (\_ -> programFlagsDescription progConf)-    defaultFlags = defaultConfigFlags progConf-    options showOrParseArgs =-         configureOptions showOrParseArgs-      ++ programConfigurationPaths   progConf showOrParseArgs-           configProgramPaths (\v fs -> fs { configProgramPaths = v })-      ++ programConfigurationOptions progConf showOrParseArgs-           configProgramArgs (\v fs -> fs { configProgramArgs = 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 NHC, ([] , ["nhc98"]), "compile with NHC")-                    , (Flag JHC, ([] , ["jhc"]), "compile with JHC")-                    , (Flag LHC, ([] , ["lhc"]), "compile with LHC")-                    , (Flag Hugs,([] , ["hugs"]), "compile with Hugs")-                    , (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 "b" ["scratchdir"]-         "directory to receive the built package (hugs-only)"-         configScratchDir (\v flags -> flags { configScratchDir = v })-         (reqArgFlag "DIR")-      --TODO: eliminate scratchdir flag--      ,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 "" ["executable-dynamic"]-         "Executable dynamic linking"-         configDynExe (\v flags -> flags { configDynExe = v })-         (boolOpt [] [])--      ,option "" ["executable-profiling"]-         "Executable profiling"-         configProfExe (\v flags -> flags { configProfExe = v })-         (boolOpt [] [])--      ,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"-         ]--      ,option "" ["library-for-ghci"]-         "compile library for use with GHCi"-         configGHCiLib (\v flags -> flags { configGHCiLib = 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 "" ["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"]-         "Use a specific package database (to satisfy dependencies and register in)"-         configPackageDB (\v flags -> flags { configPackageDB = v })-         (reqArg' "PATH" (Flag . SpecificPackageDB)-                        (\f -> case f of-                                 Flag (SpecificPackageDB db) -> [db]-                                 _ -> []))--      ,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" readFlagList showFlagList)--      ,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 "" ["extra-lib-dirs"]-         "A list of directories to search for external libraries"-         configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v})-         (reqArg' "PATH" (\x -> [x]) id)-      ,option "" ["constraint"]-         "A list of additional constraints on the dependencies."-         configConstraints (\v flags -> flags { configConstraints = v})-         (reqArg "DEPENDENCY"-                 (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))-                 (map (\x -> display x)))-      ,option "" ["tests"]-         "dependency checking and compilation for test suites listed in the package description file."-         configTests (\v flags -> flags { configTests = v })-         (boolOpt [] [])-      ,option "" ["library-coverage"]-         "build library and test suites with Haskell Program Coverage enabled. (GHC only)"-         configLibCoverage (\v flags -> flags { configLibCoverage = v })-         (boolOpt [] [])-      ,option "" ["benchmarks"]-         "dependency checking and compilation for benchmarks listed in the package description file."-         configBenchmarks (\v flags -> flags { configBenchmarks = v })-         (boolOpt [] [])-      ]-  where-    readFlagList :: String -> FlagAssignment-    readFlagList = map tagWithValue . words-      where tagWithValue ('-':fname) = (FlagName (lowercase fname), False)-            tagWithValue fname       = (FlagName (lowercase fname), True)--    showFlagList :: FlagAssignment -> [String]-    showFlagList fs = [ if not set then '-':fname else fname-                      | (FlagName fname, set) <- fs]--    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)--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 "" ["libexecdir"]-      "installation directory for program executables"-      libexecdir (\v flags -> flags { libexecdir = 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-  ]-  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 = ConfigFlags {-    configPrograms      = error "FIXME: remove configPrograms",-    configProgramPaths  = mempty,-    configProgramArgs   = mempty,-    configHcFlavor      = mempty,-    configHcPath        = mempty,-    configHcPkg         = mempty,-    configVanillaLib    = mempty,-    configProfLib       = mempty,-    configSharedLib     = mempty,-    configDynExe        = mempty,-    configProfExe       = mempty,-    configConfigureArgs = mempty,-    configOptimization  = mempty,-    configProgPrefix    = mempty,-    configProgSuffix    = mempty,-    configInstallDirs   = mempty,-    configScratchDir    = mempty,-    configDistPref      = mempty,-    configVerbosity     = mempty,-    configUserInstall   = mempty,-    configPackageDB     = mempty,-    configGHCiLib       = mempty,-    configSplitObjs     = mempty,-    configStripExes     = mempty,-    configExtraLibDirs  = mempty,-    configConstraints   = mempty,-    configExtraIncludeDirs    = mempty,-    configConfigurationsFlags = mempty,-    configTests   = mempty,-    configLibCoverage = mempty,-    configBenchmarks    = mempty-  }-  mappend a b =  ConfigFlags {-    configPrograms      = configPrograms b,-    configProgramPaths  = combine configProgramPaths,-    configProgramArgs   = combine configProgramArgs,-    configHcFlavor      = combine configHcFlavor,-    configHcPath        = combine configHcPath,-    configHcPkg         = combine configHcPkg,-    configVanillaLib    = combine configVanillaLib,-    configProfLib       = combine configProfLib,-    configSharedLib     = combine configSharedLib,-    configDynExe        = combine configDynExe,-    configProfExe       = combine configProfExe,-    configConfigureArgs = combine configConfigureArgs,-    configOptimization  = combine configOptimization,-    configProgPrefix    = combine configProgPrefix,-    configProgSuffix    = combine configProgSuffix,-    configInstallDirs   = combine configInstallDirs,-    configScratchDir    = combine configScratchDir,-    configDistPref      = combine configDistPref,-    configVerbosity     = combine configVerbosity,-    configUserInstall   = combine configUserInstall,-    configPackageDB     = combine configPackageDB,-    configGHCiLib       = combine configGHCiLib,-    configSplitObjs     = combine configSplitObjs,-    configStripExes     = combine configStripExes,-    configExtraLibDirs  = combine configExtraLibDirs,-    configConstraints   = combine configConstraints,-    configExtraIncludeDirs    = combine configExtraIncludeDirs,-    configConfigurationsFlags = combine configConfigurationsFlags,-    configTests = combine configTests,-    configLibCoverage = combine configLibCoverage,-    configBenchmarks    = combine configBenchmarks-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Copy flags--- ---------------------------------------------------------------- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity)-data CopyFlags = CopyFlags {-    copyDest      :: Flag CopyDest,-    copyDistPref  :: Flag FilePath,-    copyVerbosity :: Flag Verbosity-  }-  deriving Show--defaultCopyFlags :: CopyFlags-defaultCopyFlags  = CopyFlags {-    copyDest      = Flag NoCopyDest,-    copyDistPref  = Flag defaultDistPref,-    copyVerbosity = Flag normal-  }--copyCommand :: CommandUI CopyFlags-copyCommand = makeCommand name shortDesc longDesc defaultCopyFlags options-  where-    name       = "copy"-    shortDesc  = "Copy the files into the install locations."-    longDesc   = Just $ \_ ->-          "Does not call register, and allows a prefix at install time\n"-       ++ "Without the --destdir flag, configure determines location.\n"-    options 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 -> flags { copyDest = v })-         (reqArg "DIR" (succeedReadE (Flag . CopyTo))-                       (\f -> case f of Flag (CopyTo p) -> [p]; _ -> []))-      ]--emptyCopyFlags :: CopyFlags-emptyCopyFlags = mempty--instance Monoid CopyFlags where-  mempty = CopyFlags {-    copyDest      = mempty,-    copyDistPref  = mempty,-    copyVerbosity = mempty-  }-  mappend a b = CopyFlags {-    copyDest      = combine copyDest,-    copyDistPref  = combine copyDistPref,-    copyVerbosity = combine copyVerbosity-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Install flags--- ---------------------------------------------------------------- | Flags to @install@: (package db, verbosity)-data InstallFlags = InstallFlags {-    installPackageDB :: Flag PackageDB,-    installDistPref  :: Flag FilePath,-    installUseWrapper :: Flag Bool,-    installInPlace    :: Flag Bool,-    installVerbosity :: Flag Verbosity-  }-  deriving Show--defaultInstallFlags :: InstallFlags-defaultInstallFlags  = InstallFlags {-    installPackageDB = NoFlag,-    installDistPref  = Flag defaultDistPref,-    installUseWrapper = Flag False,-    installInPlace    = Flag False,-    installVerbosity = Flag normal-  }--installCommand :: CommandUI InstallFlags-installCommand = makeCommand name shortDesc longDesc defaultInstallFlags options-  where-    name       = "install"-    shortDesc  = "Copy the files into the install locations. Run register."-    longDesc   = Just $ \_ ->-         "Unlike the copy command, install calls the register command.\n"-      ++ "If you want to install into a location that is not what was\n"-      ++ "specified in the configure step, use the copy command.\n"-    options 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")])-      ]--emptyInstallFlags :: InstallFlags-emptyInstallFlags = mempty--instance Monoid InstallFlags where-  mempty = InstallFlags{-    installPackageDB = mempty,-    installDistPref  = mempty,-    installUseWrapper = mempty,-    installInPlace    = mempty,-    installVerbosity = mempty-  }-  mappend a b = InstallFlags{-    installPackageDB = combine installPackageDB,-    installDistPref  = combine installDistPref,-    installUseWrapper = combine installUseWrapper,-    installInPlace    = combine installInPlace,-    installVerbosity = combine installVerbosity-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * SDist flags--- ---------------------------------------------------------------- | Flags to @sdist@: (snapshot, verbosity)-data SDistFlags = SDistFlags {-    sDistSnapshot  :: Flag Bool,-    sDistDirectory :: Flag FilePath,-    sDistDistPref  :: Flag FilePath,-    sDistVerbosity :: Flag Verbosity-  }-  deriving Show--defaultSDistFlags :: SDistFlags-defaultSDistFlags = SDistFlags {-    sDistSnapshot  = Flag False,-    sDistDirectory = mempty,-    sDistDistPref  = Flag defaultDistPref,-    sDistVerbosity = Flag normal-  }--sdistCommand :: CommandUI SDistFlags-sdistCommand = makeCommand name shortDesc longDesc defaultSDistFlags options-  where-    name       = "sdist"-    shortDesc  = "Generate a source distribution file (.tar.gz)."-    longDesc   = Nothing-    options showOrParseArgs =-      [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v })-      ,optionDistPref-         sDistDistPref (\d flags -> flags { sDistDistPref = d })-         showOrParseArgs--      ,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"-         sDistDirectory (\v flags -> flags { sDistDirectory = v })-         (reqArgFlag "DIR")-      ]--emptySDistFlags :: SDistFlags-emptySDistFlags = mempty--instance Monoid SDistFlags where-  mempty = SDistFlags {-    sDistSnapshot  = mempty,-    sDistDirectory = mempty,-    sDistDistPref  = mempty,-    sDistVerbosity = mempty-  }-  mappend a b = SDistFlags {-    sDistSnapshot  = combine sDistSnapshot,-    sDistDirectory = combine sDistDirectory,-    sDistDistPref  = combine sDistDistPref,-    sDistVerbosity = combine sDistVerbosity-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * 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,-    regVerbosity   :: Flag Verbosity-  }-  deriving Show--defaultRegisterFlags :: RegisterFlags-defaultRegisterFlags = RegisterFlags {-    regPackageDB   = NoFlag,-    regGenScript   = Flag False,-    regGenPkgConf  = NoFlag,-    regInPlace     = Flag False,-    regDistPref    = Flag defaultDistPref,-    regVerbosity   = Flag normal-  }--registerCommand :: CommandUI RegisterFlags-registerCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options-  where-    name       = "register"-    shortDesc  = "Register this package with the compiler."-    longDesc   = Nothing-    options 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"-         regGenPkgConf (\v flags -> flags { regGenPkgConf  = v })-         (optArg' "PKG" Flag flagToList)-      ]--unregisterCommand :: CommandUI RegisterFlags-unregisterCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options-  where-    name       = "unregister"-    shortDesc  = "Unregister this package with the compiler."-    longDesc   = Nothing-    options 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 = RegisterFlags {-    regPackageDB   = mempty,-    regGenScript   = mempty,-    regGenPkgConf  = mempty,-    regInPlace     = mempty,-    regDistPref    = mempty,-    regVerbosity   = mempty-  }-  mappend a b = RegisterFlags {-    regPackageDB   = combine regPackageDB,-    regGenScript   = combine regGenScript,-    regGenPkgConf  = combine regGenPkgConf,-    regInPlace     = combine regInPlace,-    regDistPref    = combine regDistPref,-    regVerbosity   = combine regVerbosity-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * HsColour flags--- --------------------------------------------------------------data HscolourFlags = HscolourFlags {-    hscolourCSS         :: Flag FilePath,-    hscolourExecutables :: Flag Bool,-    hscolourDistPref    :: Flag FilePath,-    hscolourVerbosity   :: Flag Verbosity-  }-  deriving Show--emptyHscolourFlags :: HscolourFlags-emptyHscolourFlags = mempty--defaultHscolourFlags :: HscolourFlags-defaultHscolourFlags = HscolourFlags {-    hscolourCSS         = NoFlag,-    hscolourExecutables = Flag False,-    hscolourDistPref    = Flag defaultDistPref,-    hscolourVerbosity   = Flag normal-  }--instance Monoid HscolourFlags where-  mempty = HscolourFlags {-    hscolourCSS         = mempty,-    hscolourExecutables = mempty,-    hscolourDistPref    = mempty,-    hscolourVerbosity   = mempty-  }-  mappend a b = HscolourFlags {-    hscolourCSS         = combine hscolourCSS,-    hscolourExecutables = combine hscolourExecutables,-    hscolourDistPref    = combine hscolourDistPref,-    hscolourVerbosity   = combine hscolourVerbosity-  }-    where combine field = field a `mappend` field b--hscolourCommand :: CommandUI HscolourFlags-hscolourCommand = makeCommand name shortDesc longDesc defaultHscolourFlags options-  where-    name       = "hscolour"-    shortDesc  = "Generate HsColour colourised code, in HTML format."-    longDesc   = Just (\_ -> "Requires hscolour.\n")-    options 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 "" ["css"]-         "Use a cascading style sheet"-         hscolourCSS (\v flags -> flags { hscolourCSS = v })-         (reqArgFlag "PATH")-      ]---- --------------------------------------------------------------- * Haddock flags--- --------------------------------------------------------------data HaddockFlags = HaddockFlags {-    haddockProgramPaths :: [(String, FilePath)],-    haddockProgramArgs  :: [(String, [String])],-    haddockHoogle       :: Flag Bool,-    haddockHtml         :: Flag Bool,-    haddockHtmlLocation :: Flag String,-    haddockExecutables  :: Flag Bool,-    haddockInternal     :: Flag Bool,-    haddockCss          :: Flag FilePath,-    haddockHscolour     :: Flag Bool,-    haddockHscolourCss  :: Flag FilePath,-    haddockContents     :: Flag PathTemplate,-    haddockDistPref     :: Flag FilePath,-    haddockVerbosity    :: Flag Verbosity-  }-  deriving Show--defaultHaddockFlags :: HaddockFlags-defaultHaddockFlags  = HaddockFlags {-    haddockProgramPaths = mempty,-    haddockProgramArgs  = [],-    haddockHoogle       = Flag False,-    haddockHtml         = Flag False,-    haddockHtmlLocation = NoFlag,-    haddockExecutables  = Flag False,-    haddockInternal     = Flag False,-    haddockCss          = NoFlag,-    haddockHscolour     = Flag False,-    haddockHscolourCss  = NoFlag,-    haddockContents     = NoFlag,-    haddockDistPref     = Flag defaultDistPref,-    haddockVerbosity    = Flag normal-  }--haddockCommand :: CommandUI HaddockFlags-haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options-  where-    name       = "haddock"-    shortDesc  = "Generate Haddock HTML documentation."-    longDesc   = Just $ \_ -> "Requires the program haddock, either version 0.x or 2.x.\n"-    options showOrParseArgs =-      [optionVerbosity haddockVerbosity (\v flags -> flags { haddockVerbosity = v })-      ,optionDistPref-         haddockDistPref (\d flags -> flags { haddockDistPref = d })-         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 "" ["executables"]-         "Run haddock for Executables targets"-         haddockExecutables (\v flags -> flags { haddockExecutables = 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"]-         "Hyperlink the documentation to the source code (using HsColour)"-         haddockHscolour (\v flags -> flags { haddockHscolour = 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))-      ]-      ++ programConfigurationPaths   progConf ParseArgs-             haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})-      ++ programConfigurationOptions progConf ParseArgs-             haddockProgramArgs  (\v flags -> flags { haddockProgramArgs = v})-    progConf = addKnownProgram haddockProgram-             $ addKnownProgram ghcProgram-             $ emptyProgramConfiguration--emptyHaddockFlags :: HaddockFlags-emptyHaddockFlags = mempty--instance Monoid HaddockFlags where-  mempty = HaddockFlags {-    haddockProgramPaths = mempty,-    haddockProgramArgs  = mempty,-    haddockHoogle       = mempty,-    haddockHtml         = mempty,-    haddockHtmlLocation = mempty,-    haddockExecutables  = mempty,-    haddockInternal     = mempty,-    haddockCss          = mempty,-    haddockHscolour     = mempty,-    haddockHscolourCss  = mempty,-    haddockContents     = mempty,-    haddockDistPref     = mempty,-    haddockVerbosity    = mempty-  }-  mappend a b = HaddockFlags {-    haddockProgramPaths = combine haddockProgramPaths,-    haddockProgramArgs  = combine haddockProgramArgs,-    haddockHoogle       = combine haddockHoogle,-    haddockHtml         = combine haddockHoogle,-    haddockHtmlLocation = combine haddockHtmlLocation,-    haddockExecutables  = combine haddockExecutables,-    haddockInternal     = combine haddockInternal,-    haddockCss          = combine haddockCss,-    haddockHscolour     = combine haddockHscolour,-    haddockHscolourCss  = combine haddockHscolourCss,-    haddockContents     = combine haddockContents,-    haddockDistPref     = combine haddockDistPref,-    haddockVerbosity    = combine haddockVerbosity-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Clean flags--- --------------------------------------------------------------data CleanFlags = CleanFlags {-    cleanSaveConf  :: Flag Bool,-    cleanDistPref  :: Flag FilePath,-    cleanVerbosity :: Flag Verbosity-  }-  deriving Show--defaultCleanFlags :: CleanFlags-defaultCleanFlags  = CleanFlags {-    cleanSaveConf  = Flag False,-    cleanDistPref  = Flag defaultDistPref,-    cleanVerbosity = Flag normal-  }--cleanCommand :: CommandUI CleanFlags-cleanCommand = makeCommand name shortDesc longDesc defaultCleanFlags options-  where-    name       = "clean"-    shortDesc  = "Clean up after a build."-    longDesc   = Just (\_ -> "Removes .hi, .o, preprocessed sources, etc.\n")-    options 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 = CleanFlags {-    cleanSaveConf  = mempty,-    cleanDistPref  = mempty,-    cleanVerbosity = mempty-  }-  mappend a b = CleanFlags {-    cleanSaveConf  = combine cleanSaveConf,-    cleanDistPref  = combine cleanDistPref,-    cleanVerbosity = combine cleanVerbosity-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Build flags--- --------------------------------------------------------------data BuildFlags = BuildFlags {-    buildProgramPaths :: [(String, FilePath)],-    buildProgramArgs :: [(String, [String])],-    buildDistPref    :: Flag FilePath,-    buildVerbosity   :: Flag Verbosity-  }-  deriving Show--{-# DEPRECATED buildVerbose "Use buildVerbosity instead" #-}-buildVerbose :: BuildFlags -> Verbosity-buildVerbose = fromFlagOrDefault normal . buildVerbosity--defaultBuildFlags :: BuildFlags-defaultBuildFlags  = BuildFlags {-    buildProgramPaths = mempty,-    buildProgramArgs = [],-    buildDistPref    = Flag defaultDistPref,-    buildVerbosity   = Flag normal-  }--buildCommand :: ProgramConfiguration -> CommandUI BuildFlags-buildCommand progConf = makeCommand name shortDesc longDesc defaultBuildFlags options-  where-    name       = "build"-    shortDesc  = "Make this package ready for installation."-    longDesc   = Nothing-    options showOrParseArgs =-      optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v })-      : optionDistPref-          buildDistPref (\d flags -> flags { buildDistPref = d })-          showOrParseArgs--      : programConfigurationPaths   progConf showOrParseArgs-          buildProgramPaths (\v flags -> flags { buildProgramPaths = v})--     ++ programConfigurationOptions progConf showOrParseArgs-          buildProgramArgs (\v flags -> flags { buildProgramArgs = v})--emptyBuildFlags :: BuildFlags-emptyBuildFlags = mempty--instance Monoid BuildFlags where-  mempty = BuildFlags {-    buildProgramPaths = mempty,-    buildProgramArgs = mempty,-    buildVerbosity   = mempty,-    buildDistPref    = mempty-  }-  mappend a b = BuildFlags {-    buildProgramPaths = combine buildProgramPaths,-    buildProgramArgs = combine buildProgramArgs,-    buildVerbosity   = combine buildVerbosity,-    buildDistPref    = combine buildDistPref-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Test flags--- --------------------------------------------------------------data TestShowDetails = Never | Failures | Always-    deriving (Eq, Ord, Enum, Bounded, Show)--knownTestShowDetails :: [TestShowDetails]-knownTestShowDetails = [minBound..maxBound]--instance Text TestShowDetails where-    disp  = Disp.text . lowercase . show--    parse = maybe Parse.pfail return . classify =<< ident-      where-        ident        = Parse.munch1 (\c -> isAlpha c || c == '_' || c == '-')-        classify str = lookup (lowercase str) enumMap-        enumMap     :: [(String, TestShowDetails)]-        enumMap      = [ (display x, x)-                       | x <- knownTestShowDetails ]----TODO: do we need this instance?-instance Monoid TestShowDetails where-    mempty = Never-    mappend 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,-    --TODO: eliminate the test list and pass it directly as positional args to the testHook-    testList :: Flag [String],-    -- TODO: think about if/how options are passed to test exes-    testOptions :: [PathTemplate]-  }--defaultTestFlags :: TestFlags-defaultTestFlags  = TestFlags {-    testDistPref  = Flag defaultDistPref,-    testVerbosity = Flag normal,-    testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log",-    testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log",-    testShowDetails = toFlag Failures,-    testKeepTix = toFlag False,-    testList = Flag [],-    testOptions = []-  }--testCommand :: CommandUI TestFlags-testCommand = makeCommand name shortDesc longDesc defaultTestFlags options-  where-    name       = "test"-    shortDesc  = "Run the test suite, if any (configure with UserHooks)."-    longDesc   = Nothing-    options 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.")-            testShowDetails (\v flags -> flags { testShowDetails = v })-            (reqArg "FILTER"-                (readP_to_E (\_ -> "--show-details flag expects one of "-                              ++ intercalate ", "-                                   (map display knownTestShowDetails))-                            (fmap toFlag parse))-                (flagToList . fmap display))-      , option [] ["keep-tix-files"]-            "keep .tix files for HPC between test runs"-            testKeepTix (\v flags -> flags { testKeepTix = 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 = TestFlags {-    testDistPref  = mempty,-    testVerbosity = mempty,-    testHumanLog = mempty,-    testMachineLog = mempty,-    testShowDetails = mempty,-    testKeepTix = mempty,-    testList = mempty,-    testOptions = mempty-  }-  mappend a b = TestFlags {-    testDistPref  = combine testDistPref,-    testVerbosity = combine testVerbosity,-    testHumanLog = combine testHumanLog,-    testMachineLog = combine testMachineLog,-    testShowDetails = combine testShowDetails,-    testKeepTix = combine testKeepTix,-    testList = combine testList,-    testOptions = combine testOptions-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Benchmark flags--- --------------------------------------------------------------data BenchmarkFlags = BenchmarkFlags {-    benchmarkDistPref  :: Flag FilePath,-    benchmarkVerbosity :: Flag Verbosity,-    benchmarkOptions :: [PathTemplate]-  }--defaultBenchmarkFlags :: BenchmarkFlags-defaultBenchmarkFlags  = BenchmarkFlags {-    benchmarkDistPref  = Flag defaultDistPref,-    benchmarkVerbosity = Flag normal,-    benchmarkOptions = []-  }--benchmarkCommand :: CommandUI BenchmarkFlags-benchmarkCommand = makeCommand name shortDesc longDesc defaultBenchmarkFlags options-  where-    name       = "bench"-    shortDesc  = "Run the benchmark, if any (configure with UserHooks)."-    longDesc   = Nothing-    options 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 = BenchmarkFlags {-    benchmarkDistPref  = mempty,-    benchmarkVerbosity = mempty,-    benchmarkOptions = mempty-  }-  mappend a b = BenchmarkFlags {-    benchmarkDistPref  = combine benchmarkDistPref,-    benchmarkVerbosity = combine benchmarkVerbosity,-    benchmarkOptions = combine benchmarkOptions-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Shared options utils--- --------------------------------------------------------------programFlagsDescription :: ProgramConfiguration -> String-programFlagsDescription progConf =-     "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 progConf ]-  ++ "\n"--programConfigurationPaths-  :: ProgramConfiguration-  -> ShowOrParseArgs-  -> (flags -> [(String, FilePath)])-  -> ([(String, FilePath)] -> (flags -> flags))-  -> [OptionField flags]-programConfigurationPaths progConf 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 progConf)-  where-    withProgramPath prog =-      option "" ["with-" ++ prog]-        ("give the path to " ++ prog)-        get set-        (reqArg' "PATH" (\path -> [(prog, path)])-          (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ]))--programConfigurationOptions-  :: ProgramConfiguration-  -> ShowOrParseArgs-  -> (flags -> [(String, [String])])-  -> ([(String, [String])] -> (flags -> flags))-  -> [OptionField flags]-programConfigurationOptions progConf 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", programOption   "PROG"]-    ParseArgs -> map (programOptions . programName . fst) (knownPrograms progConf)-              ++ map (programOption  . programName . fst) (knownPrograms progConf)-  where-    programOptions prog =-      option "" [prog ++ "-options"]-        ("give extra options to " ++ prog)-        get set-        (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))--    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' ]))----- --------------------------------------------------------------- * 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 :: SFlags -> LFlags -> Description -> (b -> Flag Bool) ->-                     (Flag Bool -> (b -> b)) -> OptDescr b-trueArg  = noArg (Flag True)-falseArg = noArg (Flag False)--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))---- --------------------------------------------------------------- * 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- ++ 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 ++ display 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 -> ProgramConfiguration -> IO (FilePath, [String])-configureCCompiler verbosity lbi = configureProg verbosity lbi gccProgram--configureLinker :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String])-configureLinker verbosity lbi = configureProg verbosity lbi ldProgram--configureProg :: Verbosity -> ProgramConfiguration -> Program -> IO (FilePath, [String])-configureProg verbosity programConfig prog = do-    (p, _) <- requireProgram verbosity prog programConfig-    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 :: 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 ( 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?--}
− Distribution/Simple/SrcDist.hs 
@@ -1,441 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.SrcDist--- Copyright   :  Simon Marlow 2004------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This handles the @sdist@ command. The module exports an 'sdist' action but--- also some of the phases that make it up so that other tools can use just the--- bits they need. In particular the preparation of the tree of files to go--- into the source tarball is separated from actually building the source--- tarball.------ 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.--{- Copyright (c) 2003-2004, Simon Marlow-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}---- 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,--  -- ** Snaphots-  prepareSnapshotTree,-  snapshotPackage,-  snapshotVersion,-  dateToSnapshotNumber,-  )  where--import Distribution.PackageDescription-         ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..)-         , TestSuite(..), TestSuiteInterface(..), Benchmark(..)-         , BenchmarkInterface(..) )-import Distribution.PackageDescription.Check-         ( PackageCheck(..), checkConfiguredPackage, checkPackageFiles )-import Distribution.Package-         ( PackageIdentifier(pkgVersion), Package(..), packageVersion )-import Distribution.ModuleName (ModuleName)-import qualified Distribution.ModuleName as ModuleName-import Distribution.Version-         ( Version(versionBranch) )-import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File-         , installOrdinaryFile, installOrdinaryFiles, setFileExecutable-         , findFile, findFileWithExtension, matchFileGlob-         , withTempDirectory, defaultPackageDesc-         , die, warn, notice, setupMessage )-import Distribution.Simple.Setup (SDistFlags(..), fromFlag, flagToMaybe)-import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessComponent)-import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), withComponentsLBI )-import Distribution.Simple.BuildPaths ( autogenModuleName )-import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram,-                              rawSystemProgram, tarProgram )-import Distribution.Text-         ( display )--import Control.Monad(when, unless)-import Data.Char (toLower)-import Data.List (partition, isPrefixOf)-import Data.Maybe (isNothing, catMaybes)-import System.Time (getClockTime, toCalendarTime, CalendarTime(..))-import System.Directory-         ( doesFileExist, Permissions(executable), getPermissions )-import Distribution.Verbosity (Verbosity)-import System.FilePath-         ( (</>), (<.>), takeDirectory, dropExtension, isAbsolute )---- |Create a source distribution.-sdist :: PackageDescription -- ^information from the tarball-      -> Maybe LocalBuildInfo -- ^Information from configure-      -> SDistFlags -- ^verbosity & snapshot-      -> (FilePath -> FilePath) -- ^build prefix (temp dir)-      -> [PPSuffixHandler]  -- ^ extra preprocessors (includes suffixes)-      -> IO ()-sdist pkg mb_lbi flags mkTmpDir pps = do--  -- do some QA-  printPackageProblems verbosity pkg--  when (isNothing mb_lbi) $-    warn verbosity "Cannot run preprocessors. Run 'configure' command first."--  date <- toCalendarTime =<< getClockTime-  let pkg' | snapshot  = snapshotPackage date pkg-           | otherwise = pkg--  case flagToMaybe (sDistDirectory flags) of-    Just targetDir -> do-      generateSourceDir targetDir pkg'-      notice verbosity $ "Source directory created: " ++ targetDir--    Nothing -> do-      createDirectoryIfMissingVerbose verbosity True tmpTargetDir-      withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do-        let targetDir = tmpDir </> tarBallName pkg'-        generateSourceDir targetDir pkg'-        targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref-        notice verbosity $ "Source tarball created: " ++ targzFile--  where-    generateSourceDir targetDir pkg' = do--      setupMessage verbosity "Building source dist for" (packageId pkg')-      prepareTree verbosity pkg' mb_lbi distPref targetDir pps-      when snapshot $-        overwriteSnapshotPackageDesc verbosity pkg' targetDir--    verbosity = fromFlag (sDistVerbosity flags)-    snapshot  = fromFlag (sDistSnapshot flags)--    distPref     = fromFlag $ sDistDistPref flags-    targetPref   = distPref-    tmpTargetDir = mkTmpDir distPref----- |Prepare a directory tree of source files.-prepareTree :: Verbosity          -- ^verbosity-            -> PackageDescription -- ^info from the cabal file-            -> Maybe LocalBuildInfo-            -> FilePath           -- ^dist dir-            -> FilePath           -- ^source tree to populate-            -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)-            -> IO ()-prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do-  createDirectoryIfMissingVerbose verbosity True targetDir--  -- maybe move the library files into place-  withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->-    prepareDir verbosity pkg_descr distPref targetDir pps modules libBi--  -- move the executables into place-  withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do-    prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi-    srcMainFile <- do-      ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) (dropExtension mainPath)-      case ppFile of-        Nothing -> findFile (hsSourceDirs exeBi) mainPath-        Just pp -> return pp-    copyFileTo verbosity targetDir srcMainFile--  -- move the test suites into place-  withTest $ \t -> do-    let bi = testBuildInfo t-        prep = prepareDir verbosity pkg_descr distPref targetDir pps-    case testInterface t of-        TestSuiteExeV10 _ mainPath -> do-            prep [] bi-            srcMainFile <- do-                ppFile <- findFileWithExtension (ppSuffixes pps)-                                                (hsSourceDirs bi)-                                                (dropExtension mainPath)-                case ppFile of-                    Nothing -> findFile (hsSourceDirs bi) mainPath-                    Just pp -> return pp-            copyFileTo verbosity targetDir srcMainFile-        TestSuiteLibV09 _ m -> do-            prep [m] bi-        TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp--  -- move the benchmarks into place-  withBenchmark $ \bm -> do-    let bi = benchmarkBuildInfo bm-        prep = prepareDir verbosity pkg_descr distPref targetDir pps-    case benchmarkInterface bm of-        BenchmarkExeV10 _ mainPath -> do-            prep [] bi-            srcMainFile <- do-                ppFile <- findFileWithExtension (ppSuffixes pps)-                                                (hsSourceDirs bi)-                                                (dropExtension mainPath)-                case ppFile of-                    Nothing -> findFile (hsSourceDirs bi) mainPath-                    Just pp -> return pp-            copyFileTo verbosity targetDir srcMainFile-        BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: " ++ show tp--  flip mapM_ (dataFiles pkg_descr) $ \ filename -> do-    files <- matchFileGlob (dataDir pkg_descr </> filename)-    let dir = takeDirectory (dataDir pkg_descr </> filename)-    createDirectoryIfMissingVerbose verbosity True (targetDir </> dir)-    sequence_ [ installOrdinaryFile verbosity file (targetDir </> file)-              | file <- files ]--  when (not (null (licenseFile pkg_descr))) $-    copyFileTo verbosity targetDir (licenseFile pkg_descr)-  flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do-    files <- matchFileGlob fpath-    sequence_-      [ do copyFileTo verbosity targetDir file-           -- preserve executable bit on extra-src-files like ./configure-           perms <- getPermissions file-           when (executable perms) --only checks user x bit-                (setFileExecutable (targetDir </> file))-      | file <- files ]--  -- copy the install-include files-  withLib $ \ l -> do-    let lbi = libBuildInfo l-        relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)-    incs <- mapM (findInc relincdirs) (installIncludes lbi)-    flip mapM_ incs $ \(_,fpath) ->-       copyFileTo verbosity targetDir fpath--  -- if the package was configured then we can run platform independent-  -- pre-processors and include those generated files-  case mb_lbi of-    Just lbi | not (null pps) -> do-      let lbi' = lbi{ buildDir = targetDir </> buildDir lbi }   -      withComponentsLBI pkg_descr lbi' $ \c _ ->-        preprocessComponent pkg_descr c lbi' True verbosity pps-    _ -> return ()--  -- setup isn't listed in the description file.-  hsExists <- doesFileExist "Setup.hs"-  lhsExists <- doesFileExist "Setup.lhs"-  if hsExists then copyFileTo verbosity targetDir "Setup.hs"-    else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs"-    else writeUTF8File (targetDir </> "Setup.hs") $ unlines [-                "import Distribution.Simple",-                "main = defaultMain"]-  -- the description file itself-  descFile <- defaultPackageDesc verbosity-  installOrdinaryFile verbosity descFile (targetDir </> descFile)--  where-    pkg_descr = mapAllBuildInfo filterAutogenModule pkg_descr0-    filterAutogenModule bi = bi {-      otherModules = filter (/=autogenModule) (otherModules bi)-    }-    autogenModule = autogenModuleName pkg_descr0--    findInc [] f = die ("can't find include file " ++ f)-    findInc (d:ds) f = do-      let path = (d </> f)-      b <- doesFileExist path-      if b then return (f,path) else findInc ds f--    -- We have to deal with all libs and executables, so we have local-    -- versions of these functions that ignore the 'buildable' attribute:-    withLib action = maybe (return ()) action (library pkg_descr)-    withExe action = mapM_ action (executables pkg_descr)-    withTest action = mapM_ action (testSuites pkg_descr)-    withBenchmark action = mapM_ action (benchmarks pkg_descr)---- | 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-                    -> Maybe LocalBuildInfo-                    -> FilePath           -- ^dist dir-                    -> FilePath           -- ^source tree to populate-                    -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)-                    -> IO ()-prepareSnapshotTree verbosity pkg mb_lbi distPref targetDir pps = do-  prepareTree verbosity pkg mb_lbi distPref targetDir pps-  overwriteSnapshotPackageDesc verbosity pkg targetDir--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--  where-    replaceVersion :: Version -> String -> String-    replaceVersion version line-      | "version:" `isPrefixOf` map toLower line-                  = "version: " ++ display version-      | otherwise = line---- | Modifies a 'PackageDescription' by appending a snapshot number--- corresponding to the given date.----snapshotPackage :: CalendarTime -> PackageDescription -> PackageDescription-snapshotPackage date 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 :: CalendarTime -> Version -> Version-snapshotVersion date version = version {-    versionBranch = versionBranch version-                 ++ [dateToSnapshotNumber date]-  }---- | Given a date produce a corresponding integer representation.--- For example given a date @18/03/2008@ produce the number @20080318@.----dateToSnapshotNumber :: CalendarTime -> Int-dateToSnapshotNumber date = year  * 10000-                          + month * 100-                          + day-  where-    year  = ctYear date-    month = fromEnum (ctMonth date) + 1-    day   = ctDay date---- |Create an archive from a tree of source files, and clean up the tree.-createArchive :: Verbosity            -- ^verbosity-              -> PackageDescription   -- ^info from cabal file-              -> Maybe LocalBuildInfo -- ^info from configure-              -> FilePath             -- ^source tree to archive-              -> FilePath             -- ^name of archive to create-              -> IO FilePath--createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do-  let tarBallFilePath = targetPref </> tarBallName pkg_descr <.> "tar.gz"--  (tarProg, _) <- requireProgram verbosity tarProgram-                    (maybe defaultProgramConfiguration withPrograms mb_lbi)--   -- Hmm: I could well be skating on thinner ice here by using the -C option (=> GNU tar-specific?)-   -- [The prev. solution used pipes and sub-command sequences to set up the paths correctly,-   -- which is problematic in a Windows setting.]-  rawSystemProgram verbosity tarProg-           ["-C", tmpDir, "-czf", tarBallFilePath, tarBallName pkg_descr]-  return tarBallFilePath---- |Move the sources into place based on buildInfo-prepareDir :: Verbosity -- ^verbosity-           -> PackageDescription -- ^info from the cabal file-           -> FilePath           -- ^dist dir-           -> FilePath  -- ^TargetPrefix-           -> [PPSuffixHandler]  -- ^ extra preprocessors (includes suffixes)-           -> [ModuleName]  -- ^Exposed modules-           -> BuildInfo-           -> IO ()-prepareDir verbosity _pkg _distPref inPref pps modules bi-    = do let searchDirs = hsSourceDirs bi-         sources <- sequence-           [ let file = ModuleName.toFilePath module_-              in findFileWithExtension suffixes searchDirs file-             >>= maybe (notFound module_) return-           | module_ <- modules ++ otherModules bi ]-         bootFiles <- sequence-           [ let file = ModuleName.toFilePath module_-                 fileExts = ["hs-boot", "lhs-boot"]-              in findFileWithExtension fileExts (hsSourceDirs bi) file-           | module_ <- modules ++ otherModules bi ]--         let allSources = sources ++ catMaybes bootFiles ++ cSources bi-         installOrdinaryFiles verbosity inPref (zip (repeat []) allSources)--    where suffixes = ppSuffixes pps ++ ["hs", "lhs"]-          notFound m = die $ "Error: Could not find module: " ++ display m-                          ++ " with any suffix: " ++ show suffixes--copyFileTo :: Verbosity -> FilePath -> FilePath -> IO ()-copyFileTo verbosity dir file = do-  let targetFile = dir </> file-  createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)-  installOrdinaryFile verbosity file targetFile--printPackageProblems :: Verbosity -> PackageDescription -> IO ()-printPackageProblems verbosity pkg_descr = do-  ioChecks      <- checkPackageFiles pkg_descr "."-  let pureChecks = checkConfiguredPackage pkg_descr-      isDistError (PackageDistSuspicious _) = False-      isDistError _                         = True-      (errors, warnings) = partition isDistError (pureChecks ++ ioChecks)-  unless (null errors) $-      notice verbosity $ "Distribution quality errors:\n"-                      ++ unlines (map explanation errors)-  unless (null warnings) $-      notice verbosity $ "Distribution quality warnings:\n"-                      ++ unlines (map explanation warnings)-  unless (null errors) $-      notice verbosity-        "Note: the public hackage server would reject this package."------------------------------------------------------------------ | The name of the tarball without extension----tarBallName :: PackageDescription -> String-tarBallName = display . packageId--mapAllBuildInfo :: (BuildInfo -> BuildInfo)-                -> (PackageDescription -> PackageDescription)-mapAllBuildInfo f pkg = pkg {-    library     = fmap mapLibBi (library pkg),-    executables = fmap mapExeBi (executables pkg),-    testSuites  = fmap mapTestBi (testSuites pkg),-    benchmarks  = fmap mapBenchBi (benchmarks pkg)-  }-  where-    mapLibBi lib  = lib { libBuildInfo       = f (libBuildInfo lib) }-    mapExeBi exe  = exe { buildInfo          = f (buildInfo exe) }-    mapTestBi t   = t   { testBuildInfo      = f (testBuildInfo t) }-    mapBenchBi bm = bm  { benchmarkBuildInfo = f (benchmarkBuildInfo bm) }
− Distribution/Simple/Test.hs 
@@ -1,501 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Test--- Copyright   :  Thomas Tuegel 2010------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ 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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.Test-    ( test-    , runTests-    , writeSimpleTestStub-    , stubFilePath-    , stubName-    , PackageLog(..)-    , TestSuiteLog(..)-    , Case(..)-    , suitePassed, suiteFailed, suiteError-    ) where--import Distribution.Compat.TempFile ( openTempFile )-import Distribution.ModuleName ( ModuleName )-import Distribution.Package-    ( PackageId )-import qualified Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(buildable)-         , TestSuite(..)-         , TestSuiteInterface(..), testType, hasTests )-import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )-import Distribution.Simple.BuildPaths ( exeExtension )-import Distribution.Simple.Compiler ( Compiler(..), CompilerId )-import Distribution.Simple.Hpc-    ( markupPackage, markupTest, tixDir, tixFilePath )-import Distribution.Simple.InstallDirs-    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)-    , substPathTemplate , toPathTemplate, PathTemplate )-import qualified Distribution.Simple.LocalBuildInfo as LBI-    ( LocalBuildInfo(..) )-import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag )-import Distribution.Simple.Utils ( die, notice )-import qualified Distribution.TestSuite as TestSuite-    ( Test, Result(..), ImpureTestable(..), TestOptions(..), Options(..) )-import Distribution.Text-import Distribution.Verbosity ( normal, Verbosity )-import Distribution.System ( buildPlatform, Platform )--import Control.Exception ( bracket )-import Control.Monad ( when, liftM, unless, filterM )-import Data.Char ( toUpper )-import Data.Monoid ( mempty )-import System.Directory-    ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist-    , getCurrentDirectory, getDirectoryContents, removeDirectoryRecursive-    , removeFile )-import System.Environment ( getEnvironment )-import System.Exit ( ExitCode(..), exitFailure, exitWith )-import System.FilePath ( (</>), (<.>) )-import System.IO ( hClose, IOMode(..), openFile )-import System.Process ( runProcess, waitForProcess )---- | 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)---- | A 'PackageLog' with package and platform information specified.-localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog-localPackageLog pkg_descr lbi = PackageLog-    { package = PD.package pkg_descr-    , compiler = compilerId $ LBI.compiler lbi-    , platform = buildPlatform-    , testSuites = []-    }---- | Logs test suite results, itemized by test case.-data TestSuiteLog = TestSuiteLog-    { name :: String-    , cases :: [Case]-    , logFile :: FilePath    -- path to human-readable log file-    }-    deriving (Read, Show, Eq)--data Case = Case-    { caseName :: String-    , caseOptions :: TestSuite.Options-    , caseResult :: TestSuite.Result-    }-    deriving (Read, Show, Eq)--getTestOptions :: TestSuite.Test -> TestSuiteLog -> IO TestSuite.Options-getTestOptions t l =-    case filter ((== TestSuite.name t) . caseName) (cases l) of-        (x:_) -> return $ caseOptions x-        _ -> TestSuite.defaultOptions t---- | From a 'TestSuiteLog', determine if the test suite passed.-suitePassed :: TestSuiteLog -> Bool-suitePassed = all (== TestSuite.Pass) . map caseResult . cases---- | From a 'TestSuiteLog', determine if the test suite failed.-suiteFailed :: TestSuiteLog -> Bool-suiteFailed = any isFail . map caseResult . cases-    where isFail (TestSuite.Fail _) = True-          isFail _ = False---- | From a 'TestSuiteLog', determine if the test suite encountered errors.-suiteError :: TestSuiteLog -> Bool-suiteError = any isError . map caseResult . cases-    where isError (TestSuite.Error _) = True-          isError _ = False---- | Run a test executable, logging the output and generating the appropriate--- summary messages.-testController :: TestFlags-               -- ^ flags Cabal was invoked with-               -> PD.PackageDescription-               -- ^ description of package the test suite belongs to-               -> LBI.LocalBuildInfo-               -- ^ information from the configure step-               -> PD.TestSuite-               -- ^ TestSuite being tested-               -> (FilePath -> String)-               -- ^ prepare standard input for test executable-               -> FilePath -- ^ executable name-               -> (ExitCode -> String -> TestSuiteLog)-               -- ^ generator for the TestSuiteLog-               -> (TestSuiteLog -> FilePath)-               -- ^ generator for final human-readable log filename-               -> IO TestSuiteLog-testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do-    let distPref = fromFlag $ testDistPref flags-        verbosity = fromFlag $ testVerbosity flags-        testLogDir = distPref </> "test"-        options = map (testOption pkg_descr lbi suite) $ testOptions flags--    pwd <- getCurrentDirectory-    existingEnv <- getEnvironment-    let dataDirPath = pwd </> PD.dataDir pkg_descr-        shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath)-                        : ("HPCTIXFILE", (</>) pwd-                            $ tixFilePath distPref $ PD.testName suite)-                        : existingEnv--    bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog ->-        bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do--            -- Check that the test executable exists.-            exists <- doesFileExist cmd-            unless exists $ die $ "Error: Could not find test program \"" ++ cmd-                                  ++ "\". Did you build the package first?"--            -- Remove old .tix files if appropriate.-            unless (fromFlag $ testKeepTix flags) $ do-                let tDir = tixDir distPref $ PD.testName suite-                exists <- doesDirectoryExist tDir-                when exists $ removeDirectoryRecursive tDir--            -- Create directory for HPC files.-            createDirectoryIfMissing True $ tixDir distPref $ PD.testName suite--            -- Write summary notices indicating start of test suite-            notice verbosity $ summarizeSuiteStart $ PD.testName suite--            -- Prepare standard input for test executable-            appendFile tempInput $ preTest tempInput--            -- Run test executable-            exit <- do-              hLog <- openFile tempLog AppendMode-              hIn  <- openFile tempInput ReadMode-              -- these handles get closed by runProcess-              proc <- runProcess cmd options Nothing shellEnv-                        (Just hIn) (Just hLog) (Just hLog)-              waitForProcess proc--            -- Generate TestSuiteLog from executable exit code and a machine--            -- readable test log-            suiteLog <- fmap (postTest exit $!) $ readFile tempInput--            -- Generate final log file name-            let finalLogName = testLogDir </> logNamer suiteLog-                suiteLog' = suiteLog { logFile = finalLogName }--            -- Write summary notice to log file indicating start of test suite-            appendFile (logFile suiteLog') $ summarizeSuiteStart $ PD.testName suite--            -- Append contents of temporary log file to the final human--            -- readable log file-            readFile tempLog >>= appendFile (logFile 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 suiteLog) || details == Always)-                    && verbosity >= normal-            whenPrinting $ readFile tempLog >>=-                putStr . unlines . lines--            -- Write summary notice to terminal indicating end of test suite-            notice verbosity $ summarizeSuiteFinish suiteLog'--            markupTest verbosity lbi distPref-                (display $ PD.package pkg_descr) suite--            return suiteLog'-    where-        deleteIfExists file = do-            exists <- doesFileExist file-            when exists $ removeFile file--        openCabalTemp testLogDir = do-            (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log"-            hClose h >> return f----- |Perform the \"@.\/setup test@\" action.-test :: PD.PackageDescription   -- ^information from the .cabal file-     -> LBI.LocalBuildInfo      -- ^information from the configure step-     -> TestFlags               -- ^flags sent to test-     -> IO ()-test pkg_descr lbi flags = do-    let verbosity = fromFlag $ testVerbosity flags-        humanTemplate = fromFlag $ testHumanLog flags-        machineTemplate = fromFlag $ testMachineLog flags-        distPref = fromFlag $ testDistPref flags-        testLogDir = distPref </> "test"-        testNames = fromFlag $ testList flags-        pkgTests = PD.testSuites pkg_descr-        enabledTests = [ t | t <- pkgTests-                           , PD.testEnabled t-                           , PD.buildable (PD.testBuildInfo t) ]--        doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog-        doTest (suite, mLog) = do-            let testLogPath = testSuiteLogPath humanTemplate pkg_descr lbi-                go pre cmd post = testController flags pkg_descr lbi suite-                                                 pre cmd post testLogPath-            case PD.testInterface suite of-              PD.TestSuiteExeV10 _ _ -> do-                    let cmd = LBI.buildDir lbi </> PD.testName suite-                            </> PD.testName suite <.> exeExtension-                        preTest _ = ""-                        postTest exit _ =-                            let r = case exit of-                                    ExitSuccess -> TestSuite.Pass-                                    ExitFailure c -> TestSuite.Fail-                                        $ "exit code: " ++ show c-                            in TestSuiteLog-                                { name = PD.testName suite-                                , cases = [Case (PD.testName suite) mempty r]-                                , logFile = ""-                                }-                    go preTest cmd postTest--              PD.TestSuiteLibV09 _ _ -> do-                    let cmd = LBI.buildDir lbi </> stubName suite-                            </> stubName suite <.> exeExtension-                        oldLog = case mLog of-                            Nothing -> TestSuiteLog-                                { name = PD.testName suite-                                , cases = []-                                , logFile = []-                                }-                            Just l -> l-                        preTest f = show $ oldLog { logFile = f }-                        postTest _ = read-                    go preTest cmd postTest--              _ -> return TestSuiteLog-                            { name = PD.testName suite-                            , cases = [Case (PD.testName suite) mempty-                                $ TestSuite.Error $ "No support for running "-                                ++ "test suite type: "-                                ++ show (disp $ PD.testType suite)]-                            , logFile = ""-                            }--    when (not $ PD.hasTests pkg_descr) $ do-        notice verbosity "Package has no test suites."-        exitWith ExitSuccess--    when (PD.hasTests pkg_descr && null enabledTests) $-        die $ "No test suites enabled. Did you remember to configure with "-              ++ "\'--enable-tests\'?"--    testsToRun <- case testNames of-            [] -> return $ zip enabledTests $ repeat Nothing-            names -> flip mapM names $ \tName ->-                let testMap = zip enabledNames enabledTests-                    enabledNames = map PD.testName enabledTests-                    allNames = map PD.testName pkgTests-                in case lookup tName testMap of-                    Just t -> return (t, Nothing)-                    _ | tName `elem` allNames ->-                          die $ "Package configured with test suite "-                                ++ tName ++ " disabled."-                      | otherwise -> die $ "no such test: " ++ tName--    createDirectoryIfMissing True testLogDir--    -- Delete ordinary files from test log directory.-    getDirectoryContents testLogDir-        >>= filterM doesFileExist . map (testLogDir </>)-        >>= mapM_ removeFile--    let totalSuites = length testsToRun-    notice verbosity $ "Running " ++ show totalSuites ++ " test suites..."-    suites <- mapM 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--    markupPackage verbosity lbi distPref (display $ PD.package pkg_descr)-        $ map fst testsToRun--    unless allOk exitFailure---- | 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 cases' = map caseResult $ concatMap cases $ testSuites packageLog-        passedCases = length $ filter (== TestSuite.Pass) cases'-        totalCases = length cases'-        passedSuites = length $ filter suitePassed $ testSuites packageLog-        totalSuites = length $ testSuites packageLog-    notice verbosity $ show passedSuites ++ " of " ++ show totalSuites-        ++ " test suites (" ++ show passedCases ++ " of "-        ++ show totalCases ++ " test cases) passed."-    return $! passedSuites == totalSuites---- | Print a summary of a single test case's result to the console, supressing--- output for certain verbosity or test filter levels.-summarizeCase :: Verbosity -> TestShowDetails -> Case -> IO ()-summarizeCase verbosity details t =-    when shouldPrint $ notice verbosity $ "Test case " ++ caseName t-        ++ ": " ++ show (caseResult t)-    where shouldPrint = (details > Never) && (notPassed || details == Always)-          notPassed = caseResult t /= TestSuite.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-    [ "Test suite " ++ name testLog ++ ": " ++ resStr-    , "Test suite logged to: " ++ logFile testLog-    ]-    where resStr = map toUpper (resultString testLog)--summarizeSuiteStart :: String -> String-summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n"--resultString :: TestSuiteLog -> String-resultString l | suiteError l = "error"-               | suiteFailed l = "fail"-               | otherwise = "pass"--testSuiteLogPath :: PathTemplate-                 -> PD.PackageDescription-                 -> LBI.LocalBuildInfo-                 -> TestSuiteLog-                 -> FilePath-testSuiteLogPath template pkg_descr lbi testLog =-    fromPathTemplate $ substPathTemplate env template-    where-        env = initialPathTemplateEnv-                (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)-                ++  [ (TestSuiteNameVar, toPathTemplate $ name testLog)-                    , (TestSuiteResultVar, result)-                    ]-        result = toPathTemplate $ resultString testLog---- TODO: This is abusing the notion of a 'PathTemplate'.  The result--- isn't neccesarily a path.-testOption :: PD.PackageDescription-           -> LBI.LocalBuildInfo-           -> PD.TestSuite-           -> PathTemplate-           -> String-testOption pkg_descr lbi suite template =-    fromPathTemplate $ substPathTemplate env template-  where-    env = initialPathTemplateEnv-          (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) ++-          [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]--packageLogPath :: PathTemplate-               -> PD.PackageDescription-               -> LBI.LocalBuildInfo-               -> FilePath-packageLogPath template pkg_descr lbi =-    fromPathTemplate $ substPathTemplate env template-    where-        env = initialPathTemplateEnv-                (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)---- | The filename of the source file for the stub executable associated with a--- library 'TestSuite'.-stubFilePath :: PD.TestSuite -> FilePath-stubFilePath t = stubName t <.> "hs"---- | The name of the stub executable associated with a library 'TestSuite'.-stubName :: PD.TestSuite -> FilePath-stubName t = PD.testName t ++ "Stub"---- | 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 t dir = do-    createDirectoryIfMissing True dir-    let filename = dir </> stubFilePath t-        PD.TestSuiteLibV09 _ m = PD.testInterface t-    writeFile filename $ simpleTestStub m---- | Source code for library test suite stub executable-simpleTestStub :: ModuleName -> String-simpleTestStub m = unlines-    [ "module Main ( main ) where"-    , "import Control.Monad ( liftM )"-    , "import Distribution.Simple.Test ( runTests )"-    , "import " ++ show (disp m) ++ " ( tests )"-    , "main :: IO ()"-    , "main = runTests tests"-    ]---- | 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--- the child of a Cabal process during @.\/setup test@.  A 'TestSuiteLog',--- provided by Cabal, is read from the standard input; it supplies the name of--- the test suite and the location of the machine-readable test suite log file.--- Human-readable log information is written to the standard output for capture--- by the calling Cabal process.-runTests :: [TestSuite.Test] -> IO ()-runTests tests = do-    testLogIn <- liftM read getContents-    let go :: TestSuite.Test -> IO Case-        go t = do-            o <- getTestOptions t testLogIn-            r <- TestSuite.runM t o-            let ret = Case-                    { caseName = TestSuite.name t-                    , caseOptions = o-                    , caseResult = r-                    }-            summarizeCase normal Always ret-            return ret-    cases' <- mapM go tests-    let testLog = testLogIn { cases = cases'}-    writeFile (logFile testLog) $ show testLog-    when (suiteError testLog) $ exitWith $ ExitFailure 2-    when (suiteFailed testLog) $ exitWith $ ExitFailure 1-    exitWith ExitSuccess
− Distribution/Simple/UHC.hs 
@@ -1,300 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.UHC--- Copyright   :  Andres Loeh 2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module contains most of the UHC-specific code for configuring, building--- and installing packages.------ 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.--{--Copyright (c) 2009, Andres Loeh-Copyright (c) 2003-2005, Isaac Jones-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.UHC (-    configure, getInstalledPackages,-    buildLib, buildExe, installLib, registerPackage-  ) where--import Control.Monad-import Data.List-import Distribution.Compat.ReadP-import Distribution.InstalledPackageInfo-import Distribution.Package-import Distribution.PackageDescription-import Distribution.Simple.BuildPaths-import Distribution.Simple.Compiler as C-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.PackageIndex-import Distribution.Simple.Program-import Distribution.Simple.Utils-import Distribution.Text-import Distribution.Verbosity-import Distribution.Version-import Language.Haskell.Extension-import System.Directory-import System.FilePath---- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)-configure verbosity hcPath _hcPkgPath conf = do--  (_uhcProg, uhcVersion, conf') <--    requireProgramVersion verbosity uhcProgram-    (orLaterVersion (Version [1,0,2] []))-    (userMaybeSpecifyPath "uhc" hcPath conf)--  let comp = Compiler {-               compilerId          =  CompilerId UHC uhcVersion,-               compilerLanguages   =  uhcLanguages,-               compilerExtensions  =  uhcLanguageExtensions-             }-  return (comp, conf')--uhcLanguages :: [(Language, C.Flag)]-uhcLanguages = [(Haskell98, "")]---- | The flags for the supported extensions.-uhcLanguageExtensions :: [(Extension, C.Flag)]-uhcLanguageExtensions =-    let doFlag (f, (enable, disable)) = [(EnableExtension  f, enable),-                                         (DisableExtension f, disable)]-        alwaysOn = ("", ""{- wrong -})-    in concatMap doFlag-    [(CPP,                          ("--cpp", ""{- wrong -})),-     (PolymorphicComponents,        alwaysOn),-     (ExistentialQuantification,    alwaysOn),-     (ForeignFunctionInterface,     alwaysOn),-     (UndecidableInstances,         alwaysOn),-     (MultiParamTypeClasses,        alwaysOn),-     (Rank2Types,                   alwaysOn),-     (PatternSignatures,            alwaysOn),-     (EmptyDataDecls,               alwaysOn),-     (ImplicitPrelude,              ("", "--no-prelude"{- wrong -})),-     (TypeOperators,                alwaysOn),-     (OverlappingInstances,         alwaysOn),-     (FlexibleInstances,            alwaysOn)]--getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration-                     -> IO PackageIndex-getInstalledPackages verbosity comp packagedbs conf = do-  let compilerid = compilerId comp-  systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram conf ["--meta-pkgdir-system"]-  userPkgDir   <- getUserPackageDir-  let pkgDirs    = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs)-  -- putStrLn $ "pkgdirs: " ++ show pkgDirs-  -- call to "lines" necessary, because pkgdir contains an extra newline at the end-  pkgs <- liftM (map addBuiltinVersions . concat) .-          mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d)) .-          concatMap lines $ pkgDirs-  -- putStrLn $ "pkgs: " ++ show pkgs-  let iPkgs =-        map mkInstalledPackageInfo $-        concatMap parsePackage $-        pkgs-  -- putStrLn $ "installed pkgs: " ++ show iPkgs-  return (fromList iPkgs)--getUserPackageDir :: IO FilePath-getUserPackageDir =-  do-    homeDir <- getHomeDirectory-    return $ homeDir </> ".cabal" </> "lib"  -- TODO: determine in some other way--packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]-packageDbPaths user system db =-  case db of-    GlobalPackageDB         ->  [ system ]-    UserPackageDB           ->  [ user ]-    SpecificPackageDB path  ->  [ path ]---- | Hack to add version numbers to UHC-builtin packages. This should sooner or--- later be fixed on the UHC side.-addBuiltinVersions :: String -> String-{--addBuiltinVersions "uhcbase"  = "uhcbase-1.0"-addBuiltinVersions "base"  = "base-3.0"-addBuiltinVersions "array" = "array-0.2"--}-addBuiltinVersions xs      = xs---- | Name of the installed package config file.-installedPkgConfig :: String-installedPkgConfig = "installed-pkg-config"---- | Check if a certain dir contains a valid package. Currently, we are--- 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)--parsePackage :: String -> [PackageId]-parsePackage x = map fst (filter (\ (_,y) -> null y) (readP_to_S parse x))---- | Create a trivial package info from a directory name.-mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo-mkInstalledPackageInfo p = emptyInstalledPackageInfo-  { installedPackageId = InstalledPackageId (display p),-    sourcePackageId    = p }----- -------------------------------------------------------------------------------- Building--buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity pkg_descr lbi lib clbi = do--  systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"]-  userPkgDir   <- getUserPackageDir-  let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi)-  let uhcArgs =    -- set package name-                   ["--pkg-build=" ++ display (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 display (libModules lib))--  runUhcProg uhcArgs-  -  return ()--buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity _pkg_descr lbi exe clbi = do-  systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"]-  userPkgDir   <- getUserPackageDir-  let runUhcProg = rawSystemProgramConf 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 </> exeName exe]-                   -- main source module-                ++ [modulePath exe]-  runUhcProg uhcArgs--constructUHCCmdLine :: FilePath -> FilePath-                    -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo-                    -> FilePath -> Verbosity -> [String]-constructUHCCmdLine user system lbi bi clbi odir verbosity =-     -- verbosity-     (if      verbosity >= deafening then ["-v4"]-      else if verbosity >= normal    then []-      else                                ["-v0"])-  ++ hcOptions UHC bi-     -- flags for language extensions-  ++ languageToFlags   (compiler lbi) (defaultLanguage bi)-  ++ extensionsToFlags (compiler lbi) (usedExtensions bi)-     -- packages-  ++ ["--hide-all-packages"]-  ++ uhcPackageDbOptions user system (withPackageDB lbi)-  ++ ["--package=uhcbase"]-  ++ ["--package=" ++ display (pkgName pkgid) | (_, pkgid) <- componentPackageDeps clbi ]-     -- search paths-  ++ ["-i" ++ odir]-  ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]-  ++ ["-i" ++ autogenModulesDir lbi]-     -- output path-  ++ ["--odir=" ++ odir]-     -- optimization-  ++ (case withOptimization lbi of-        NoOptimisation       ->  ["-O0"]-        NormalOptimisation   ->  ["-O1"]-        MaximumOptimisation  ->  ["-O2"])--uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String]-uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x)-                                         (concatMap (packageDbPaths user system) db)---- -------------------------------------------------------------------------------- Installation--installLib :: Verbosity -> LocalBuildInfo-           -> FilePath -> FilePath -> FilePath-           -> PackageDescription -> Library -> IO ()-installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library = do-    -- putStrLn $ "dest:  " ++ targetDir-    -- putStrLn $ "built: " ++ builtDir-    installDirectoryContents verbosity (builtDir </> display (packageId pkg)) targetDir---- currently hardcoded UHC code generator and variant to use-uhcTarget, uhcTargetVariant :: String-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---- -------------------------------------------------------------------------------- Registering--registerPackage-  :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool-  -> PackageDBStack-  -> IO ()-registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do-    let installDirs = absoluteInstallDirs pkg lbi NoCopyDest-        pkgdir  | inplace   = buildDir lbi       </> uhcPackageDir    (display pkgid) (display compilerid)-                | otherwise = libdir installDirs </> uhcPackageSubDir                 (display compilerid)-    createDirectoryIfMissingVerbose verbosity True pkgdir-    writeUTF8File (pkgdir </> installedPkgConfig)-                  (showInstalledPackageInfo installedPkgInfo)-  where-    pkgid      = packageId pkg-    compilerid = compilerId (compiler lbi)
− Distribution/Simple/UserHooks.hs 
@@ -1,231 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.UserHooks--- Copyright   :  Isaac Jones 2003-2005------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This defines the API that @Setup.hs@ scripts can use to customise the way--- the build works. This module just defines the 'UserHooks' type. The--- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@--- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big--- record of functions. There are 3 for each action, a pre, post and the action--- itself. There are few other miscellaneous hooks, ones to extend the set of--- programs and preprocessors and one to override the function used to read the--- @.cabal@ file.------ This hooks type is widely agreed to not be the right solution. Partly this--- is because changes to it usually break custom @Setup.hs@ files and yet many--- internal code changes do require changes to the hooks. For example we cannot--- 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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.UserHooks (-        UserHooks(..), Args,-        emptyUserHooks,-  ) where--import Distribution.PackageDescription-         (PackageDescription, GenericPackageDescription,-          HookedBuildInfo, emptyHookedBuildInfo)-import Distribution.Simple.Program    (Program)-import Distribution.Simple.Command    (noExtraFlags)-import Distribution.Simple.PreProcess (PPSuffixHandler)-import Distribution.Simple.Setup-         (ConfigFlags, BuildFlags, CleanFlags, CopyFlags,-          InstallFlags, SDistFlags, RegisterFlags, HscolourFlags,-          HaddockFlags, TestFlags, BenchmarkFlags)-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)--type Args = [String]---- | Hooks allow authors to add specific functionality before and after a--- command is run, and also to specify additional preprocessors.------ * 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 {--    -- | Used for @.\/setup test@-    runTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO (),-    -- | 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 gbet 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 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 sdist command.  Second arg indicates verbosity level.-    preSDist  :: Args -> SDistFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during sdist.-    sDistHook :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO (),-    -- |Hook to run after sdist command.  Second arg indicates verbosity level.-    postSDist :: Args -> SDistFlags -> PackageDescription -> Maybe 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 registration.-    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 :: 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 ()-  }--{-# DEPRECATED runTests "Please use the new testing interface instead!" #-}---- |Empty 'UserHooks' which do nothing.-emptyUserHooks :: UserHooks-emptyUserHooks-  = UserHooks {-      runTests  = ru,-      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,-      preClean  = rn,-      cleanHook = ru,-      postClean = ru,-      preCopy   = rn,-      copyHook  = ru,-      postCopy  = ru,-      preInst   = rn,-      instHook  = ru,-      postInst  = ru,-      preSDist  = rn,-      sDistHook = ru,-      postSDist = 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 = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without-                                                     -- noExtraFlags-      testHook = ru,-      postTest = ru,-      preBench = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without-                                                      -- noExtraFlags-      benchHook = \_ -> ru,-      postBench = ru-    }-    where rn args  _ = noExtraFlags args >> return emptyHookedBuildInfo-          ru _ _ _ _ = return ()
− Distribution/Simple/Utils.hs 
@@ -1,1141 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp -fffi #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Utils--- Copyright   :  Isaac Jones, Simon Marlow 2003-2004---                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.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Simple.Utils (-        cabalVersion,--        -- * logging and errors-        die,-        dieWithLocation,-        topHandler,-        warn, notice, setupMessage, info, debug,-        chattyTry,--        -- * running programs-        rawSystemExit,-        rawSystemExitCode,-        rawSystemExitWithEnv,-        rawSystemStdout,-        rawSystemStdInOut,-        maybeExit,-        xargs,-        findProgramLocation,-        findProgramVersion,--        -- * copying files-        smartCopySources,-        createDirectoryIfMissingVerbose,-        copyFileVerbose,-        copyDirectoryRecursiveVerbose,-        copyFiles,--        -- * installing files-        installOrdinaryFile,-        installExecutableFile,-        installOrdinaryFiles,-        installDirectoryContents,--        -- * File permissions-        setFileOrdinary,-        setFileExecutable,--        -- * file names-        currentDir,--        -- * finding files-        findFile,-        findFirstFile,-        findFileWithExtension,-        findFileWithExtension',-        findModuleFile,-        findModuleFiles,-        getDirectoryContentsRecursive,--        -- * simple file globbing-        matchFileGlob,-        matchDirFileGlob,-        parseFileGlob,-        FileGlob(..),--        -- * temp files and dirs-        withTempFile,-        withTempDirectory,--        -- * .cabal and .buildinfo files-        defaultPackageDesc,-        findPackageDesc,-        defaultHookedPackageDesc,-        findHookedPackageDesc,--        -- * reading and writing files safely-        withFileContents,-        writeFileAtomic,-        rewriteFile,--        -- * Unicode-        fromUTF8,-        toUTF8,-        readUTF8File,-        withUTF8FileContents,-        writeUTF8File,-        normaliseLineEndings,--        -- * generic utils-        equating,-        comparing,-        isInfixOf,-        intercalate,-        lowercase,-        wrapText,-        wrapLine,-  ) where--import Control.Monad-    ( when, unless, filterM )-#ifdef __GLASGOW_HASKELL__-import Control.Concurrent.MVar-    ( newEmptyMVar, putMVar, takeMVar )-#endif-import Data.List-    ( nub, unfoldr, isPrefixOf, tails, intersperse )-import Data.Char as Char-    ( toLower, chr, ord )-import Data.Bits-    ( Bits((.|.), (.&.), shiftL, shiftR) )--import System.Directory-    ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile-    , findExecutable )-import System.Environment-    ( getProgName )-import System.Cmd-    ( rawSystem )-import System.Exit-    ( exitWith, ExitCode(..) )-import System.FilePath-    ( normalise, (</>), (<.>), takeDirectory, splitFileName-    , splitExtension, splitExtensions, splitDirectories )-import System.Directory-    ( createDirectory, renameFile, removeDirectoryRecursive )-import System.IO-    ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode-    , hGetContents, stderr, stdout, hPutStr, hFlush, hClose )-import System.IO.Error as IO.Error-    ( isDoesNotExistError, isAlreadyExistsError-    , ioeSetFileName, ioeGetFileName, ioeGetErrorString )-#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608))-import System.IO.Error-    ( ioeSetLocation, ioeGetLocation )-#endif-import System.IO.Unsafe-    ( unsafeInterleaveIO )-import qualified Control.Exception as Exception--import Distribution.Text-    ( display, simpleParse )-import Distribution.Package-    ( PackageIdentifier )-import Distribution.ModuleName (ModuleName)-import qualified Distribution.ModuleName as ModuleName-import Distribution.Version-    (Version(..))--import Control.Exception (evaluate)-import System.Process (runProcess)--#ifdef __GLASGOW_HASKELL__-import Control.Concurrent (forkIO)-import System.Process (runInteractiveProcess, waitForProcess)-#else-import System.Cmd (system)-import System.Directory (getTemporaryDirectory)-#endif--import Distribution.Compat.CopyFile-         ( copyFile, copyOrdinaryFile, copyExecutableFile-         , setFileOrdinary, setFileExecutable, setDirOrdinary )-import Distribution.Compat.TempFile-         ( openTempFile, openNewBinaryFile, createTempDirectory )-import Distribution.Compat.Exception-         ( IOException, throwIOIO, tryIO, catchIO, catchExit, onException )-import Distribution.Verbosity--#ifdef VERSION_base-import qualified Paths_Cabal (version)-#endif---- We only get our own version number when we're building with ourselves-cabalVersion :: Version-#if defined(VERSION_base)-cabalVersion = Paths_Cabal.version-#elif defined(CABAL_VERSION)-cabalVersion = Version [CABAL_VERSION] []-#else-cabalVersion = Version [1,9999] []  --used when bootstrapping-#endif---- ------------------------------------------------------------------------------- Exception and logging utils--dieWithLocation :: FilePath -> Maybe Int -> String -> IO a-dieWithLocation filename lineno msg =-  ioError . setLocation lineno-          . flip ioeSetFileName (normalise filename)-          $ userError msg-  where-#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)-    setLocation _        err = err-#else-    setLocation Nothing  err = err-    setLocation (Just n) err = ioeSetLocation err (show n)-#endif--die :: String -> IO a-die msg = ioError (userError msg)--topHandler :: IO a -> IO a-topHandler prog = catchIO prog handle-  where-    handle ioe = do-      hFlush stdout-      pname <- getProgName-      hPutStr stderr (mesage pname)-      exitWith (ExitFailure 1)-      where-        mesage pname = wrapText (pname ++ ": " ++ file ++ detail)-        file         = case ioeGetFileName ioe of-                         Nothing   -> ""-                         Just path -> path ++ location ++ ": "-#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)-        location     = ""-#else-        location     = case ioeGetLocation ioe of-                         l@(n:_) | n >= '0' && n <= '9' -> ':' : l-                         _                              -> ""-#endif-        detail       = ioeGetErrorString ioe---- | 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 =-  when (verbosity >= normal) $ do-    hFlush stdout-    hPutStr stderr (wrapText ("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 =-  when (verbosity >= normal) $-    putStr (wrapText msg)--setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()-setupMessage verbosity msg pkgid =-    notice verbosity (msg ++ ' ': display 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 =-  when (verbosity >= verbose) $-    putStr (wrapText msg)---- | Detailed internal debugging information------ We display these messages when the verbosity level is 'deafening'----debug :: Verbosity -> String -> IO ()-debug verbosity msg =-  when (verbosity >= deafening) $ do-    putStr (wrapText msg)-    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 ->-    putStrLn $ "Error while " ++ desc ++ ": " ++ show exception---- -------------------------------------------------------------------------------- Helper functions---- | Wraps text to the default line width. Existing newlines are preserved.-wrapText :: String -> String-wrapText = unlines-         . concatMap (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]---- -------------------------------------------------------------------------------- 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- | verbosity >= deafening = print (path, args)- | verbosity >= verbose   = putStrLn $ unwords (path : args)- | otherwise              = return ()--printRawCommandAndArgsAndEnv :: Verbosity-                             -> FilePath-                             -> [String]-                             -> [(String, String)]-                             -> IO ()-printRawCommandAndArgsAndEnv verbosity path args env- | verbosity >= deafening = do putStrLn ("Environment: " ++ show env)-                               print (path, args)- | verbosity >= verbose   = putStrLn $ unwords (path : args)- | otherwise              = return ()---- Exit with the same exitcode if the subcommand fails-rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()-rawSystemExit verbosity path args = 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 = 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 = do-    printRawCommandAndArgsAndEnv verbosity path args env-    hFlush stdout-    ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing-    exitcode <- waitForProcess ph-    unless (exitcode == ExitSuccess) $ do-        debug verbosity $ path ++ " returned " ++ show exitcode-        exitWith exitcode---- | Run a command and return its output.------ The output is assumed to be text in the locale encoding.----rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String-rawSystemStdout verbosity path args = do-  (output, errors, exitCode) <- rawSystemStdInOut verbosity path args-                                                  Nothing False-  when (exitCode /= ExitSuccess) $-    die 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 :: Verbosity-                  -> FilePath -> [String]-                  -> Maybe (String, Bool) -- ^ input text and binary mode-                  -> Bool                 -- ^ output in binary mode-                  -> IO (String, String, ExitCode) -- ^ output, errors, exit-rawSystemStdInOut verbosity path args input outputBinary = do-  printRawCommandAndArgs verbosity path args--#ifdef __GLASGOW_HASKELL__-  Exception.bracket-     (runInteractiveProcess path args Nothing Nothing)-     (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)-    $ \(inh,outh,errh,pid) -> do--      -- output mode depends on what the caller wants-      hSetBinaryMode outh outputBinary-      -- 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.--      err <- hGetContents errh-      out <- hGetContents outh--      mv <- newEmptyMVar-      let force str = (evaluate (length str) >> return ())-            `Exception.finally` putMVar mv ()-          --TODO: handle exceptions like text decoding.-      _ <- forkIO $ force out-      _ <- forkIO $ force err--      -- push all the input, if any-      case input of-        Nothing -> return ()-        Just (inputStr, inputBinary) -> do-                -- input mode depends on what the caller wants-          hSetBinaryMode inh inputBinary-          hPutStr inh inputStr-          hClose inh-          --TODO: this probably fails if the process refuses to consume-          -- or if it closes stdin (eg if it exits)--      -- wait for both to finish, in either order-      takeMVar mv-      takeMVar mv--      -- wait for the program to terminate-      exitcode <- waitForProcess pid-      unless (exitcode == ExitSuccess) $-        debug verbosity $ path ++ " returned " ++ show exitcode-                       ++ if null err then "" else-                          " with error message:\n" ++ err--      return (out, err, exitcode)-#else-  tmpDir <- getTemporaryDirectory-  withTempFile tmpDir ".cmd.stdout" $ \outName outHandle ->-   withTempFile tmpDir ".cmd.stdin" $ \inName inHandle -> do-    hClose outHandle--    case input of-      Nothing -> return ()-      Just (inputStr, inputBinary) -> do-        hSetBinaryMode inHandle inputBinary-        hPutStr inHandle inputStr-    hClose inHandle--    let quote name = "'" ++ name ++ "'"-        cmd = unwords (map quote (path:args))-           ++ " <" ++ quote inName-           ++ " >" ++ quote outName-    exitcode <- system cmd--    unless (exitcode == ExitSuccess) $-      debug verbosity $ path ++ " returned " ++ show exitcode--    Exception.bracket (openFile outName ReadMode) hClose $ \hnd -> do-      hSetBinaryMode hnd outputBinary-      output <- hGetContents hnd-      length output `seq` return (output, "", exitcode)-#endif----- | Look for a program on the path.-findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath)-findProgramLocation verbosity prog = do-  debug verbosity $ "searching for " ++ prog ++ " in path."-  res <- findExecutable prog-  case res of-      Nothing   -> debug verbosity ("Cannot find " ++ prog ++ " on the path")-      Just path -> debug verbosity ("found " ++ prog ++ " at "++ path)-  return res----- | 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 = do-  str <- rawSystemStdout verbosity path [versionArg]-         `catchIO`   (\_ -> return "")-         `catchExit` (\_ -> return "")-  let version :: Maybe Version-      version = simpleParse (selectVersion str)-  case version of-      Nothing -> warn verbosity $ "cannot determine version of " ++ path-                               ++ " :\n" ++ show str-      Just v  -> debug verbosity $ path ++ " is version " ++ display 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 mapM_ (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.----findFile :: [FilePath]    -- ^search locations-         -> FilePath      -- ^File Name-         -> IO FilePath-findFile searchPath fileName =-  findFirstFile id-    [ path </> fileName-    | path <- nub searchPath]-  >>= maybe (die $ 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 ]---- | 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---- | Finds the files corresponding to a list of Haskell module names.------ As 'findModuleFile' but for a list of module names.----findModuleFiles :: [FilePath]   -- ^ build prefix (location of objects)-                -> [String]     -- ^ search suffixes-                -> [ModuleName] -- ^ modules-                -> IO [(FilePath, FilePath)]-findModuleFiles searchPath extensions moduleNames =-  mapM (findModuleFile 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.----findModuleFile :: [FilePath]  -- ^ build prefix (location of objects)-               -> [String]    -- ^ search suffixes-               -> ModuleName  -- ^ module-               -> IO (FilePath, FilePath)-findModuleFile searchPath extensions moduleName =-      maybe notFound return-  =<< findFileWithExtension' extensions searchPath-                             (ModuleName.toFilePath moduleName)-  where-    notFound = die $ "Error: Could not find module: " ++ display moduleName-                  ++ " 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--------------------- File globbing--data FileGlob-   -- | No glob at all, just an ordinary file-   = NoGlob FilePath--   -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to-   --    @FileGlob \"foo\/bar\" \".baz\"@-   | FileGlob FilePath String--parseFileGlob :: FilePath -> Maybe FileGlob-parseFileGlob filepath = case splitExtensions filepath of-  (filepath', ext) -> case splitFileName filepath' of-    (dir, "*") | '*' `elem` dir-              || '*' `elem` ext-              || null ext            -> Nothing-               | null dir            -> Just (FileGlob "." ext)-               | otherwise           -> Just (FileGlob dir ext)-    _          | '*' `elem` filepath -> Nothing-               | otherwise           -> Just (NoGlob filepath)--matchFileGlob :: FilePath -> IO [FilePath]-matchFileGlob = matchDirFileGlob "."--matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath]-matchDirFileGlob dir filepath = case parseFileGlob filepath of-  Nothing -> die $ "invalid file glob '" ++ filepath-                ++ "'. Wildcards '*' are only allowed in place of the file"-                ++ " name, not in the directory name or file extension."-                ++ " If a wildcard is used it must be with an file extension."-  Just (NoGlob filepath') -> return [filepath']-  Just (FileGlob dir' ext) -> do-    files <- getDirectoryContents (dir </> dir')-    case   [ dir' </> file-           | file <- files-           , let (name, ext') = splitExtensions file-           , not (null name) && ext' == ext ] of-      []      -> die $ "filepath wildcard '" ++ filepath-                    ++ "' does not match any files."-      matches -> return matches--------------------------------------------- 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 = createDirs (parents path0)-  | otherwise      = createDirs (take 1 (parents path0))-  where-    parents = reverse . scanl1 (</>) . splitDirectories . normalise--    createDirs []         = return ()-    createDirs (dir:[])   = createDir dir throwIOIO-    createDirs (dir:dirs) =-      createDir dir $ \_ -> do-        createDirs dirs-        createDir dir throwIOIO--    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 exeption 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-              if isDir then return ()-                       else throwIOIO e-              ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())-          | otherwise              -> throwIOIO e--createDirectoryVerbose :: Verbosity -> FilePath -> IO ()-createDirectoryVerbose verbosity dir = 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 = 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 = 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 = do-  info verbosity ("Installing executable " ++ src ++ " to " ++ dest)-  copyExecutableFile src dest---- | 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 verbosity targetDir srcFiles = do--  -- Create parent directories for everything-  let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles-  mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs--  -- Copy all the files-  sequence_ [ let src  = srcBase   </> srcFile-                  dest = targetDir </> srcFile-               in copyFileVerbose verbosity src dest-            | (srcBase, srcFile) <- srcFiles ]---- | This is like 'copyFiles' but uses 'installOrdinaryFile'.----installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()-installOrdinaryFiles verbosity targetDir srcFiles = do--  -- Create parent directories for everything-  let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles-  mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs--  -- Copy all the files-  sequence_ [ let src  = srcBase   </> srcFile-                  dest = targetDir </> srcFile-               in installOrdinaryFile verbosity src dest-            | (srcBase, srcFile) <- srcFiles ]---- | 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 = do-  info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")-  srcFiles <- getDirectoryContentsRecursive srcDir-  installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]-------------------------------------- Deprecated file copy functions--{-# DEPRECATED smartCopySources-      "Use findModuleFiles and copyFiles or installOrdinaryFiles" #-}-smartCopySources :: Verbosity -> [FilePath] -> FilePath-                 -> [ModuleName] -> [String] -> IO ()-smartCopySources verbosity searchPath targetDir moduleNames extensions =-      findModuleFiles searchPath extensions moduleNames-  >>= copyFiles verbosity targetDir--{-# DEPRECATED copyDirectoryRecursiveVerbose-      "You probably want installDirectoryContents instead" #-}-copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO ()-copyDirectoryRecursiveVerbose verbosity srcDir destDir = do-  info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")-  srcFiles <- getDirectoryContentsRecursive srcDir-  copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]-------------------------------- Temporary files and dirs---- | 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 =-  Exception.bracket-    (openTempFile tmpDir template)-    (\(name, handle) -> hClose handle >> removeFile name)-    (uncurry action)---- | 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 =-  Exception.bracket-    (createTempDirectory targetDir template)-    (removeDirectoryRecursive)---------------------------------------- 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 =-  Exception.bracket (openFile name ReadMode) hClose-                    (\hnd -> hGetContents hnd >>= action)---- | Writes a file atomically.------ The file is either written sucessfully 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 -> String -> IO ()-writeFileAtomic targetFile content = do-  (tmpFile, tmpHandle) <- openNewBinaryFile targetDir template-  do  hPutStr tmpHandle content-      hClose tmpHandle-      renameFile tmpFile targetFile-   `onException` do hClose tmpHandle-                    removeFile tmpFile-  where-    template = targetName <.> "tmp"-    targetDir | null targetDir_ = currentDir-              | otherwise       = targetDir_-    --TODO: remove this when takeDirectory/splitFileName is fixed-    --      to always return a valid dir-    (targetDir_,targetName) = splitFileName targetFile---- | 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.----rewriteFile :: FilePath -> String -> IO ()-rewriteFile path newContent =-  flip catchIO mightNotExist $ do-    existingContent <- readFile path-    _ <- evaluate (length existingContent)-    unless (existingContent == newContent) $-      writeFileAtomic path newContent-  where-    mightNotExist e | isDoesNotExistError e = 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 = "."---- --------------------------------------------------------------- * Finding the description file--- ---------------------------------------------------------------- |Package description file (/pkgname/@.cabal@)-defaultPackageDesc :: Verbosity -> IO FilePath-defaultPackageDesc _verbosity = findPackageDesc currentDir---- |Find a package description file in the given directory.  Looks for--- @.cabal@ files.-findPackageDesc :: FilePath    -- ^Where to look-                -> IO FilePath -- ^<pkgname>.cabal-findPackageDesc dir- = do files <- getDirectoryContents 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-                       [ dir </> file-                       | file <- files-                       , let (name, ext) = splitExtension file-                       , not (null name) && ext == ".cabal" ]-      case cabalFiles of-        []          -> noDesc-        [cabalFile] -> return cabalFile-        multiple    -> multiDesc multiple--  where-    noDesc :: IO a-    noDesc = die $ "No cabal file found.\n"-                ++ "Please create a package description file <pkgname>.cabal"--    multiDesc :: [String] -> IO a-    multiDesc l = die $ "Multiple cabal files found.\n"-                    ++ "Please use only one of: "-                    ++ intercalate ", " l---- |Optional auxiliary package information file (/pkgname/@.buildinfo@)-defaultHookedPackageDesc :: IO (Maybe FilePath)-defaultHookedPackageDesc = findHookedPackageDesc currentDir---- |Find auxiliary package information in the given directory.--- Looks for @.buildinfo@ files.-findHookedPackageDesc-    :: FilePath                 -- ^Directory to search-    -> IO (Maybe FilePath)      -- ^/dir/@\/@/pkgname/@.buildinfo@, if present-findHookedPackageDesc 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 ("Multiple files with extension " ++ buildInfoExt)--buildInfoExt  :: String-buildInfoExt = ".buildinfo"---- --------------------------------------------------------------- * Unicode stuff--- ---------------------------------------------------------------- This is a modification of the UTF8 code from gtk2hs and the--- utf8-string package.--fromUTF8 :: String -> String-fromUTF8 []     = []-fromUTF8 (c:cs)-  | c <= '\x7F' = c : fromUTF8 cs-  | c <= '\xBF' = replacementChar : fromUTF8 cs-  | c <= '\xDF' = twoBytes c cs-  | c <= '\xEF' = moreBytes 3 0x800     cs (ord c .&. 0xF)-  | c <= '\xF7' = moreBytes 4 0x10000   cs (ord c .&. 0x7)-  | c <= '\xFB' = moreBytes 5 0x200000  cs (ord c .&. 0x3)-  | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1)-  | otherwise   = replacementChar : fromUTF8 cs-  where-    twoBytes c0 (c1:cs')-      | ord c1 .&. 0xC0 == 0x80-      = let d = ((ord c0 .&. 0x1F) `shiftL` 6)-             .|. (ord c1 .&. 0x3F)-         in if d >= 0x80-               then  chr d           : fromUTF8 cs'-               else  replacementChar : fromUTF8 cs'-    twoBytes _ cs' = replacementChar : fromUTF8 cs'--    moreBytes :: Int -> Int -> [Char] -> Int -> [Char]-    moreBytes 1 overlong cs' acc-      | overlong <= acc && acc <= 0x10FFFF-     && (acc < 0xD800 || 0xDFFF < acc)-     && (acc < 0xFFFE || 0xFFFF < acc)-      = chr acc : fromUTF8 cs'--      | otherwise-      = replacementChar : fromUTF8 cs'--    moreBytes byteCount overlong (cn:cs') acc-      | ord cn .&. 0xC0 == 0x80-      = moreBytes (byteCount-1) overlong cs'-          ((acc `shiftL` 6) .|. ord cn .&. 0x3F)--    moreBytes _ _ cs' _-      = replacementChar : fromUTF8 cs'--    replacementChar = '\xfffd'--toUTF8 :: String -> String-toUTF8 []        = []-toUTF8 (c:cs)-  | c <= '\x07F' = c-                 : toUTF8 cs-  | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6))-                 : chr (0x80 .|. (w .&. 0x3F))-                 : toUTF8 cs-  | c <= '\xFFFF'= chr (0xE0 .|.  (w `shiftR` 12))-                 : chr (0x80 .|. ((w `shiftR` 6)  .&. 0x3F))-                 : chr (0x80 .|.  (w .&. 0x3F))-                 : toUTF8 cs-  | otherwise    = chr (0xf0 .|.  (w `shiftR` 18))-                 : chr (0x80 .|. ((w `shiftR` 12)  .&. 0x3F))-                 : chr (0x80 .|. ((w `shiftR` 6)  .&. 0x3F))-                 : chr (0x80 .|.  (w .&. 0x3F))-                 : toUTF8 cs-  where w = ord c---- | 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 = fmap (ignoreBOM . fromUTF8)-               . hGetContents =<< openBinaryFile f ReadMode---- | Reads a UTF8 encoded text file as a Unicode String------ Same behaviour as 'withFileContents'.----withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a-withUTF8FileContents name action =-  Exception.bracket-    (openBinaryFile name ReadMode)-    hClose-    (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8)---- | 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 . toUTF8---- | 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 osx-normaliseLineEndings (  c :s)      =   c  : normaliseLineEndings s---- --------------------------------------------------------------- * Common utils--- --------------------------------------------------------------equating :: Eq a => (b -> a) -> b -> b -> Bool-equating p x y = p x == p y--comparing :: Ord a => (b -> a) -> b -> b -> Ordering-comparing p x y = p x `compare` p y--isInfixOf :: String -> String -> Bool-isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)--intercalate :: [a] -> [[a]] -> [a]-intercalate sep = concat . intersperse sep--lowercase :: String -> String-lowercase = map Char.toLower
− Distribution/System.hs 
@@ -1,179 +0,0 @@--------------------------------------------------------------------------------- |--- 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 \"ming32\"). 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,-  ) where--import qualified System.Info (os, arch)-import qualified Data.Char as Char (toLower, isAlphaNum)--import Distribution.Text (Text(..), display)-import qualified Distribution.Compat.ReadP as Parse-import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint ((<>))---- | 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 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--- --------------------------------------------------------------data OS = Linux | Windows | OSX        -- teir 1 desktop OSs-        | FreeBSD | OpenBSD | NetBSD   -- other free unix OSs-        | Solaris | AIX | HPUX | IRIX  -- ageing Unix OSs-        | HaLVM                        -- bare metal / VMs / hypervisors-        | OtherOS String-  deriving (Eq, Ord, Show, Read)----TODO: decide how to handle Android and iOS.--- They are like Linux and OSX but with some differences.--- Should they be separate from linux/osx, or a subtype?--- e.g. should we have os(linux) && os(android) true simultaneously?--knownOSs :: [OS]-knownOSs = [Linux, Windows, OSX-           ,FreeBSD, OpenBSD, NetBSD-           ,Solaris, AIX, HPUX, IRIX-           ,HaLVM]--osAliases :: ClassificationStrictness -> OS -> [String]-osAliases Permissive Windows = ["mingw32", "cygwin32"]-osAliases Compat     Windows = ["mingw32", "win32"]-osAliases _          OSX     = ["darwin"]-osAliases Permissive FreeBSD = ["kfreebsdgnu"]-osAliases Permissive Solaris = ["solaris2"]-osAliases _          _       = []--instance Text OS where-  disp (OtherOS name) = Disp.text name-  disp other          = Disp.text (lowercase (show other))--  parse = fmap (classifyOS Compat) ident--classifyOS :: ClassificationStrictness -> String -> OS-classifyOS strictness s =-  case lookup (lowercase s) osMap of-    Just os -> os-    Nothing -> OtherOS s-  where-    osMap = [ (name, os)-            | os <- knownOSs-            , name <- display os : osAliases strictness os ]--buildOS :: OS-buildOS = classifyOS Permissive System.Info.os---- --------------------------------------------------------------- * Machine Architecture--- --------------------------------------------------------------data Arch = I386  | X86_64 | PPC | PPC64 | Sparc-          | Arm   | Mips   | SH-          | IA64  | S390-          | Alpha | Hppa   | Rs6000-          | M68k  | Vax-          | OtherArch String-  deriving (Eq, Ord, Show, Read)--knownArches :: [Arch]-knownArches = [I386, X86_64, PPC, PPC64, Sparc-              ,Arm, Mips, SH-              ,IA64, S390-              ,Alpha, Hppa, Rs6000-              ,M68k, Vax]--archAliases :: ClassificationStrictness -> Arch -> [String]-archAliases Strict _     = []-archAliases Compat _     = []-archAliases _      PPC   = ["powerpc"]-archAliases _      PPC64 = ["powerpc64"]-archAliases _      Sparc = ["sparc64", "sun4"]-archAliases _      Mips  = ["mipsel", "mipseb"]-archAliases _      Arm   = ["armeb", "armel"]-archAliases _      _     = []--instance Text Arch where-  disp (OtherArch name) = Disp.text name-  disp other            = Disp.text (lowercase (show other))--  parse = fmap (classifyArch Strict) ident--classifyArch :: ClassificationStrictness -> String -> Arch-classifyArch strictness s =-  case lookup (lowercase s) archMap of-    Just arch -> arch-    Nothing   -> OtherArch s-  where-    archMap = [ (name, arch)-              | arch <- knownArches-              , name <- display arch : archAliases strictness arch ]--buildArch :: Arch-buildArch = classifyArch Permissive System.Info.arch---- --------------------------------------------------------------- * Platform--- --------------------------------------------------------------data Platform = Platform Arch OS-  deriving (Eq, Ord, Show, Read)--instance Text Platform where-  disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os-  parse = do-    arch <- parse-    _ <- Parse.char '-'-    os   <- parse-    return (Platform arch os)--buildPlatform :: Platform-buildPlatform = Platform buildArch buildOS---- Utils:--ident :: Parse.ReadP r String-ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')-  --TODO: probably should disallow starting with a number--lowercase :: String -> String-lowercase = map Char.toLower
− Distribution/TestSuite.hs 
@@ -1,310 +0,0 @@-{-# LANGUAGE CPP, ExistentialQuantification #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.TestSuite--- Copyright   :  Thomas Tuegel 2010------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module defines the detailed test suite interface which makes it--- possible to expose individual tests to Cabal or other test agents.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))-#define NEW_EXCEPTION-#endif--module Distribution.TestSuite-    ( -- * Example-      -- $example-      -- * Options-      Options(..)-    , lookupOption-    , TestOptions(..)-      -- * Tests-    , Test-    , pure, impure-    , Result(..)-    , ImpureTestable(..)-    , PureTestable(..)-    ) where--#ifdef NEW_EXCEPTION-import Control.Exception ( evaluate, catch, throw, SomeException, fromException )-#else-import Control.Exception ( evaluate, catch, throw, Exception(IOException) )-#endif----TODO: it is totally unreasonable that we have to import things from GHC.* here.---      see ghc ticket #3517-#ifdef __GLASGOW_HASKELL__-#if __GLASGOW_HASKELL__ >= 612-import GHC.IO.Exception  ( IOErrorType(Interrupted) )-#else-import GHC.IOBase        ( IOErrorType(Interrupted) )-#endif-import System.IO.Error   ( ioeGetErrorType )-#endif--import Data.List ( unionBy )-import Data.Monoid ( Monoid(..) )-import Data.Typeable ( TypeRep )-import Prelude hiding ( catch )---- | 'Options' are provided to pass options to test runners, making tests--- reproducable.  Each option is a @('String', 'String')@ of the form--- @(Name, Value)@.  Use 'mappend' to combine sets of 'Options'; if the same--- option is given different values, the value from the left argument of--- 'mappend' will be used.-newtype Options = Options [(String, String)]-    deriving (Read, Show, Eq)--instance Monoid Options where-    mempty = Options []-    mappend (Options a) (Options b) = Options $ unionBy (equating fst) a b-      where-        equating p x y = p x == p y---class TestOptions t where-    -- | The name of the test.-    name :: t -> String--    -- | A list of the options a test recognizes.  The name and 'TypeRep' are-    -- provided so that test agents can ensure that user-specified options are-    -- correctly typed.-    options :: t -> [(String, TypeRep)]--    -- | The default options for a test.  Test frameworks should provide a new-    -- random seed, if appropriate.-    defaultOptions :: t -> IO Options--    -- | Try to parse the provided options.  Return the names of unparsable-    -- options.  This allows test agents to detect bad user-specified options.-    check :: t -> Options -> [String]---- | Read an option from the specified set of 'Options'.  It is an error to--- lookup an option that has not been specified.  For this reason, test agents--- should 'mappend' any 'Options' against the 'defaultOptions' for a test, so--- the default value specified by the test framework will be used for any--- otherwise-unspecified options.-lookupOption :: Read r => String -> Options -> r-lookupOption n (Options opts) =-    case lookup n opts of-        Just str -> read str-        Nothing -> error $ "test option not specified: " ++ n--data Result-    = Pass          -- ^ indicates a successful test-    | Fail String   -- ^ indicates a test completed unsuccessfully;-                    -- the 'String' value should be a human-readable message-                    -- indicating how the test failed.-    | Error String  -- ^ indicates a test that could not be-                    -- completed due to some error; the test framework-                    -- should provide a message indicating the-                    -- nature of the error.-    deriving (Read, Show, Eq)---- | Class abstracting impure tests.  Test frameworks should implement this--- class only as a last resort for test types which actually require 'IO'.--- In particular, tests that simply require pseudo-random number generation can--- be implemented as pure tests.-class TestOptions t => ImpureTestable t where-    -- | Runs an impure test and returns the result.  Test frameworks-    -- implementing this class are responsible for converting any exceptions to-    -- the correct 'Result' value.-    runM :: t -> Options -> IO Result---- | Class abstracting pure tests.  Test frameworks should prefer to implement--- this class over 'ImpureTestable'.  A default instance exists so that any pure--- test can be lifted into an impure test; when lifted, any exceptions are--- automatically caught.  Test agents that lift pure tests themselves must--- handle exceptions.-class TestOptions t => PureTestable t where-    -- | The result of a pure test.-    run :: t -> Options -> Result---- | 'Test' is a wrapper for pure and impure tests so that lists containing--- arbitrary test types can be constructed.-data Test-    = forall p. PureTestable p => PureTest p-    | forall i. ImpureTestable i => ImpureTest i---- | A convenient function for wrapping pure tests into 'Test's.-pure :: PureTestable p => p -> Test-pure = PureTest---- | A convenient function for wrapping impure tests into 'Test's.-impure :: ImpureTestable i => i -> Test-impure = ImpureTest--instance TestOptions Test where-    name (PureTest p) = name p-    name (ImpureTest i) = name i--    options (PureTest p) = options p-    options (ImpureTest i) = options i--    defaultOptions (PureTest p) = defaultOptions p-    defaultOptions (ImpureTest p) = defaultOptions p--    check (PureTest p) = check p-    check (ImpureTest p) = check p--instance ImpureTestable Test where-    runM (PureTest p) o = catch (evaluate $ run p o) handler--    -- Because we have to handle old and new style exceptions, GHC and non-GHC-    -- this code is totally horrible and really fragile. Has to be tested with-    -- lots of ghc versions to check it is right, and with non-ghc too. :-(-#ifdef NEW_EXCEPTION-      where-        handler :: SomeException -> IO Result-        handler e = case fromException e of-          Just ioe | isInterruptedError ioe -> throw e-          _                                 -> return (Error (show e))-#else-      where-        handler :: Exception -> IO Result-        handler e = case e of-          IOException ioe | isInterruptedError ioe -> throw e-          _                                        -> return (Error (show e))-#endif--        -- We do not want to catch control-C here, but only GHC-        -- defines the Interrupted exception type! (ticket #3517)-        isInterruptedError ioe =-#ifdef __GLASGOW_HASKELL__-          ioeGetErrorType ioe == Interrupted-#else-          False-#endif--    runM (ImpureTest i) o = runM i o---- $example--- The following terms are used carefully throughout this file:------  [test interface]    The interface provided by this module.------  [test agent]    A program used by package users to coordinates the running---                  of tests and the reporting of their results.------  [test framework]    A package used by software authors to specify tests,---                      such as QuickCheck or HUnit.------ Test frameworks are obligated to supply, at least, instances of the--- 'TestOptions' and 'ImpureTestable' classes.  It is preferred that test--- frameworks implement 'PureTestable' whenever possible, so that test agents--- have an assurance that tests can be safely run in parallel.------ Test agents that allow the user to specify options should avoid setting--- options not listed by the 'options' method.  Test agents should use 'check'--- before running tests with non-default options.  Test frameworks must--- implement a 'check' function that attempts to parse the given options safely.------ The packages cabal-test-hunit, cabal-test-quickcheck1, and--- cabal-test-quickcheck2 provide simple interfaces to these popular test--- frameworks.  An example from cabal-test-quickcheck2 is shown below.  A--- better implementation would eliminate the console output from QuickCheck\'s--- built-in runner and provide an instance of 'PureTestable' instead of--- 'ImpureTestable'.------ > import Control.Monad (liftM)--- > import Data.Maybe (catMaybes, fromJust, maybe)--- > import Data.Typeable (Typeable(..))--- > import qualified Distribution.TestSuite as Cabal--- > import System.Random (newStdGen, next, StdGen)--- > import qualified Test.QuickCheck as QC--- >--- > data QCTest = forall prop. QC.Testable prop => QCTest String prop--- >--- > test :: QC.Testable prop => String -> prop -> Cabal.Test--- > test n p = Cabal.impure $ QCTest n p--- >--- > instance Cabal.TestOptions QCTest where--- >     name (QCTest n _) = n--- >--- >     options _ =--- >         [ ("std-gen", typeOf (undefined :: String))--- >         , ("max-success", typeOf (undefined :: Int))--- >         , ("max-discard", typeOf (undefined :: Int))--- >         , ("size", typeOf (undefined :: Int))--- >         ]--- >--- >     defaultOptions _ = do--- >         rng <- newStdGen--- >         return $ Cabal.Options $--- >             [ ("std-gen", show rng)--- >             , ("max-success", show $ QC.maxSuccess QC.stdArgs)--- >             , ("max-discard", show $ QC.maxDiscard QC.stdArgs)--- >             , ("size", show $ QC.maxSize QC.stdArgs)--- >             ]--- >--- >     check t (Cabal.Options opts) = catMaybes--- >         [ maybeNothing "max-success" ([] :: [(Int, String)])--- >         , maybeNothing "max-discard" ([] :: [(Int, String)])--- >         , maybeNothing "size" ([] :: [(Int, String)])--- >         ]--- >         -- There is no need to check the parsability of "std-gen"--- >         -- because the Read instance for StdGen always succeeds.--- >         where--- >             maybeNothing n x =--- >                 maybe Nothing (\str ->--- >                     if reads str == x then Just n else Nothing)--- >                     $ lookup n opts--- >--- > instance Cabal.ImpureTestable QCTest where--- >     runM (QCTest _ prop) o =--- >         catch go (return . Cabal.Error . show)--- >         where--- >             go = do--- >                 result <- QC.quickCheckWithResult args prop--- >                 return $ case result of--- >                         QC.Success {} -> Cabal.Pass--- >                         QC.GaveUp {}->--- >                             Cabal.Fail $ "gave up after "--- >                                        ++ show (QC.numTests result)--- >                                        ++ " tests"--- >                         QC.Failure {} -> Cabal.Fail $ QC.reason result--- >                         QC.NoExpectedFailure {} ->--- >                             Cabal.Fail "passed (expected failure)"--- >             args = QC.Args--- >                 { QC.replay = Just--- >                     ( Cabal.lookupOption "std-gen" o--- >                     , Cabal.lookupOption "size" o--- >                     )--- >                 , QC.maxSuccess = Cabal.lookupOption "max-success" o--- >                 , QC.maxDiscard = Cabal.lookupOption "max-discard" o--- >                 , QC.maxSize = Cabal.lookupOption "size" o--- >                 }
− Distribution/Text.hs 
@@ -1,68 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Text--- Copyright   :  Duncan Coutts 2007------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This defines a 'Text' class which is a bit like the 'Read' and 'Show'--- classes. The difference is that is uses a modern pretty printer and parser--- system and the format is not expected to be Haskell concrete syntax but--- rather the external human readable representation used by Cabal.----module Distribution.Text (-  Text(..),-  display,-  simpleParse,-  ) where--import qualified Distribution.Compat.ReadP as Parse-import qualified Text.PrettyPrint          as Disp--import Data.Version (Version(Version))-import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace)--class Text a where-  disp  :: a -> Disp.Doc-  parse :: Parse.ReadP r a--display :: Text a => a -> String-display = Disp.renderStyle style . disp-  where style = Disp.Style {-          Disp.mode            = Disp.PageMode,-          Disp.lineLength      = 79,-          Disp.ribbonsPerLine  = 1.0-        }--simpleParse :: Text a => String -> Maybe a-simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str-                       , all Char.isSpace s ] of-  []    -> Nothing-  (p:_) -> Just p---- -------------------------------------------------------------------------------- Instances for types from the base package--instance Text Bool where-  disp  = Disp.text . show-  parse = Parse.choice [ (Parse.string "True" Parse.+++-                          Parse.string "true") >> return True-                       , (Parse.string "False" Parse.+++-                          Parse.string "false") >> return False ]--instance Text Version where-  disp (Version branch _tags)     -- Death to version tags!!-    = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch))--  parse = do-      branch <- Parse.sepBy1 digits (Parse.char '.')-      tags   <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum)-      return (Version branch tags)  --TODO: should we ignore the tags?-    where-      digits = do-        first <- Parse.satisfy Char.isDigit-        if first == '0'-          then return 0-          else do rest <- Parse.munch Char.isDigit-                  return (read (first : rest))
− Distribution/Verbosity.hs 
@@ -1,113 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Verbosity--- Copyright   :  Ian Lynagh 2007------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ A simple 'Verbosity' type with associated utilities. There are 4 standard--- verbosity levels from 'silent', 'normal', 'verbose' up to 'deafening'. This--- is used for deciding what logging messages to print.---- Verbosity for Cabal functions--{- Copyright (c) 2007, Ian Lynagh-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Verbosity (-  -- * Verbosity-  Verbosity,-  silent, normal, verbose, deafening,-  moreVerbose, lessVerbose,-  intToVerbosity, flagToVerbosity,-  showForCabal, showForGHC- ) where--import Data.List (elemIndex)-import Distribution.ReadE--data Verbosity = Silent | Normal | Verbose | Deafening-    deriving (Show, Read, Eq, Ord, Enum, Bounded)---- We shouldn't print /anything/ unless an error occurs in silent mode-silent :: Verbosity-silent = Silent---- Print stuff we want to see by default-normal :: Verbosity-normal = Normal---- Be more verbose about what's going on-verbose :: Verbosity-verbose = Verbose---- Not only are we verbose ourselves (perhaps even noisier than when--- being "verbose"), but we tell everything we run to be verbose too-deafening :: Verbosity-deafening = Deafening--moreVerbose :: Verbosity -> Verbosity-moreVerbose Silent    = Silent    --silent should stay silent-moreVerbose Normal    = Verbose-moreVerbose Verbose   = Deafening-moreVerbose Deafening = Deafening--lessVerbose :: Verbosity -> Verbosity-lessVerbose Deafening = Deafening-lessVerbose Verbose   = Normal-lessVerbose Normal    = Silent-lessVerbose Silent    = Silent--intToVerbosity :: Int -> Maybe Verbosity-intToVerbosity 0 = Just Silent-intToVerbosity 1 = Just Normal-intToVerbosity 2 = Just Verbose-intToVerbosity 3 = Just Deafening-intToVerbosity _ = Nothing--flagToVerbosity :: ReadE Verbosity-flagToVerbosity = ReadE $ \s ->-   case reads s of-       [(i, "")] ->-           case intToVerbosity i of-               Just v -> Right v-               Nothing -> Left ("Bad verbosity: " ++ show i ++-                                     ". Valid values are 0..3")-       _ -> Left ("Can't parse verbosity " ++ s)--showForCabal, showForGHC :: Verbosity -> String--showForCabal v = maybe (error "unknown verbosity") show $-    elemIndex v [silent,normal,verbose,deafening]-showForGHC   v = maybe (error "unknown verbosity") show $-    elemIndex v [silent,normal,__,verbose,deafening]-        where __ = silent -- this will be always ignored by elemIndex
− Distribution/Version.hs 
@@ -1,742 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Version--- Copyright   :  Isaac Jones, Simon Marlow 2003-2004---                Duncan Coutts 2008------ 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\"@.--{- Copyright (c) 2003-2004, Isaac Jones-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.Version (-  -- * Package versions-  Version(..),--  -- * Version ranges-  VersionRange(..),--  -- ** Constructing-  anyVersion, noVersion,-  thisVersion, notThisVersion,-  laterVersion, earlierVersion,-  orLaterVersion, orEarlierVersion,-  unionVersionRanges, intersectVersionRanges,-  withinVersion,-  betweenVersionsInclusive,--  -- ** Inspection-  withinRange,-  isAnyVersion,-  isNoVersion,-  isSpecificVersion,-  simplifyVersionRange,-  foldVersionRange,-  foldVersionRange',--  -- * 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,-  withinIntervals,-  versionIntervals,-  mkVersionIntervals,-  unionVersionIntervals,-  intersectVersionIntervals,-- ) where--import Data.Version     ( Version(..) )--import Distribution.Text ( Text(..) )-import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.ReadP ((+++))-import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint ((<>), (<+>))-import qualified Data.Char as Char (isDigit)-import Control.Exception (assert)---- -------------------------------------------------------------------------------- Version ranges---- Todo: maybe move this to Distribution.Package.Version?--- (package-specific versioning scheme).--data VersionRange-  = AnyVersion-  | ThisVersion            Version -- = version-  | LaterVersion           Version -- > version  (NB. not >=)-  | EarlierVersion         Version -- < version-  | WildcardVersion        Version -- == ver.*   (same as >= ver && < ver+1)-  | UnionVersionRanges     VersionRange VersionRange-  | IntersectVersionRanges VersionRange VersionRange-  | VersionRangeParens     VersionRange -- just '(exp)' parentheses syntax-  deriving (Show,Read,Eq)--{-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}-{-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}-{-# DEPRECATED LaterVersion "use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}-{-# DEPRECATED EarlierVersion "use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}-{-# DEPRECATED WildcardVersion "use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}-{-# DEPRECATED UnionVersionRanges "use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-}-{-# DEPRECATED IntersectVersionRanges "use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-}---- | The version range @-any@. That is, a version range containing all--- versions.------ > withinRange v anyVersion = True----anyVersion :: VersionRange-anyVersion = AnyVersion---- | The empty version range, that is a version range containing no versions.------ This can be constructed using any unsatisfiable version range expression,--- for example @> 1 && < 1@.------ > withinRange v anyVersion = False----noVersion :: VersionRange-noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v)-  where v = Version [1] []---- | 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   v = UnionVersionRanges (ThisVersion v) (LaterVersion v)---- | 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 v = UnionVersionRanges (ThisVersion v) (EarlierVersion v)---- | 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 = WildcardVersion---- | The version range @>= v1 && <= v2@.------ In practice this is not very useful because we normally use inclusive lower--- bounds and exclusive upper bounds.------ > withinRange v' (laterVersion v) = v' > v----betweenVersionsInclusive :: Version -> Version -> VersionRange-betweenVersionsInclusive v1 v2 =-  IntersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2)--{-# DEPRECATED betweenVersionsInclusive-    "In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds"-  #-}---- | Fold over the basic syntactic structure of a 'VersionRange'.------ This provides a syntacic 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 anyv this later earlier union intersect = fold-  where-    fold AnyVersion                     = anyv-    fold (ThisVersion v)                = this v-    fold (LaterVersion v)               = later v-    fold (EarlierVersion v)             = earlier v-    fold (WildcardVersion v)            = fold (wildcard v)-    fold (UnionVersionRanges v1 v2)     = union (fold v1) (fold v2)-    fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2)-    fold (VersionRangeParens v)         = fold v--    wildcard v = intersectVersionRanges-                   (orLaterVersion v)-                   (earlierVersion (wildcardUpperBound v))---- | An extended variant of 'foldVersionRange' that also provides a view of--- in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented--- explicitly rather than in terms of the other basic syntax.----foldVersionRange' :: a                         -- ^ @\"-any\"@ version-                  -> (Version -> a)            -- ^ @\"== v\"@-                  -> (Version -> a)            -- ^ @\"> v\"@-                  -> (Version -> a)            -- ^ @\"< v\"@-                  -> (Version -> a)            -- ^ @\">= v\"@-                  -> (Version -> a)            -- ^ @\"<= v\"@-                  -> (Version -> Version -> a) -- ^ @\"== v.*\"@ wildcard. The-                                               -- function is passed the-                                               -- inclusive lower bound and the-                                               -- exclusive upper bounds of the-                                               -- range defined by the wildcard.-                  -> (a -> a -> a)             -- ^ @\"_ || _\"@ union-                  -> (a -> a -> a)             -- ^ @\"_ && _\"@ intersection-                  -> (a -> a)                  -- ^ @\"(_)\"@ parentheses-                  -> VersionRange -> a-foldVersionRange' anyv this later earlier orLater orEarlier-                  wildcard union intersect parens = fold-  where-    fold AnyVersion                     = anyv-    fold (ThisVersion v)                = this v-    fold (LaterVersion v)               = later v-    fold (EarlierVersion v)             = earlier v--    fold (UnionVersionRanges (ThisVersion    v)-                             (LaterVersion   v')) | v==v' = orLater v-    fold (UnionVersionRanges (LaterVersion   v)-                             (ThisVersion    v')) | v==v' = orLater v-    fold (UnionVersionRanges (ThisVersion    v)-                             (EarlierVersion v')) | v==v' = orEarlier v-    fold (UnionVersionRanges (EarlierVersion v)-                             (ThisVersion    v')) | v==v' = orEarlier v--    fold (WildcardVersion v)            = wildcard v (wildcardUpperBound v)-    fold (UnionVersionRanges v1 v2)     = union (fold v1) (fold v2)-    fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2)-    fold (VersionRangeParens v)         = parens (fold v)----- | 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'  -> versionBranch v == versionBranch v')-                   (\v'  -> versionBranch v >  versionBranch v')-                   (\v'  -> versionBranch v <  versionBranch v')-                   (||)-                   (&&)---- | 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---- | 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-  [(LowerBound v InclusiveBound, NoUpperBound)] | isVersion0 v -> True-  _                                                            -> False---- | 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-  [(LowerBound v  InclusiveBound-   ,UpperBound v' InclusiveBound)]-    | v == v' -> Just v-  _           -> Nothing---- | 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 (versionIntervals vi) = vr-    | otherwise                  = fromVersionIntervals vi-  where-    vi = toVersionIntervals vr--------------------------------- Wildcard range utilities-----wildcardUpperBound :: Version -> Version-wildcardUpperBound (Version lowerBound ts) = (Version upperBound ts)-  where-    upperBound = init lowerBound ++ [last lowerBound + 1]--isWildcardRange :: Version -> Version -> Bool-isWildcardRange (Version branch1 _) (Version branch2 _) = check branch1 branch2-  where check (n:[]) (m:[]) | n+1 == m = True-        check (n:ns) (m:ms) | n   == m = check ns ms-        check _      _                 = False----------------------- Intervals view------- | 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)---- | 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 (Version [0] []) InclusiveBound--isVersion0 :: Version -> Bool-isVersion0 (Version [0] _) = True-isVersion0 _               = False--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-      | null intervals = []-      | otherwise      = zip intervals (tail intervals)--checkInvariant :: VersionIntervals -> VersionIntervals-checkInvariant is = assert (invariant is) is---- | Directly construct a 'VersionIntervals' from a list of intervals.------ Each interval must be non-empty. The sequence must be in increasing order--- and no invervals may overlap or touch. If any of these conditions are not--- satisfied the function returns @Nothing@.----mkVersionIntervals :: [VersionInterval] -> Maybe VersionIntervals-mkVersionIntervals intervals-  | invariant (VersionIntervals intervals) = Just (VersionIntervals intervals)-  | otherwise                              = Nothing--validVersion :: Version -> Bool-validVersion (Version [] _) = False-validVersion (Version vs _) = all (>=0) vs--validInterval :: (LowerBound, UpperBound) -> Bool-validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i-  where-    validLower (LowerBound v _) = validVersion v-    validUpper NoUpperBound     = True-    validUpper (UpperBound v _) = validVersion v---- Check an interval is non-empty----nonEmpty :: VersionInterval -> Bool-nonEmpty (_,               NoUpperBound   ) = True-nonEmpty (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 = foldVersionRange-  (         chkIvl (minLowerBound,               NoUpperBound))-  (\v    -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound))-  (\v    -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound))-  (\v    -> if isVersion0 v then VersionIntervals [] else-            chkIvl (minLowerBound,               UpperBound v ExclusiveBound))-  unionVersionIntervals-  intersectVersionIntervals-  where-    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) =-    foldr1 UnionVersionRanges [ interval l u | (l, u) <- intervals ]--  where-    interval (LowerBound v  InclusiveBound)-             (UpperBound v' InclusiveBound) | v == v'-                 = ThisVersion v-    interval (LowerBound v  InclusiveBound)-             (UpperBound v' ExclusiveBound) | isWildcardRange v v'-                 = WildcardVersion v-    interval l u = lowerBound l `intersectVersionRanges'` upperBound u--    lowerBound (LowerBound v InclusiveBound)-                              | isVersion0 v = AnyVersion-                              | otherwise    = orLaterVersion v-    lowerBound (LowerBound v ExclusiveBound) = LaterVersion v--    upperBound NoUpperBound                  = AnyVersion-    upperBound (UpperBound v InclusiveBound) = orEarlierVersion v-    upperBound (UpperBound v ExclusiveBound) = EarlierVersion v--    intersectVersionRanges' vr AnyVersion = vr-    intersectVersionRanges' AnyVersion vr = vr-    intersectVersionRanges' vr 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'------------------------------------ Parsing and pretty printing-----instance Text VersionRange where-  disp = fst-       . foldVersionRange'                         -- precedence:-           (         Disp.text "-any"                           , 0 :: Int)-           (\v   -> (Disp.text "==" <> disp v                   , 0))-           (\v   -> (Disp.char '>'  <> disp v                   , 0))-           (\v   -> (Disp.char '<'  <> disp v                   , 0))-           (\v   -> (Disp.text ">=" <> disp v                   , 0))-           (\v   -> (Disp.text "<=" <> disp v                   , 0))-           (\v _ -> (Disp.text "==" <> dispWild v               , 0))-           (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2))-           (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1))-           (\(r, p)   -> (Disp.parens r, p))--    where dispWild (Version b _) =-               Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))-            <> Disp.text ".*"-          punct p p' | p < p'    = Disp.parens-                     | otherwise = id--  parse = expr-   where-        expr   = do Parse.skipSpaces-                    t <- term-                    Parse.skipSpaces-                    (do _  <- Parse.string "||"-                        Parse.skipSpaces-                        e <- expr-                        return (UnionVersionRanges t e)-                     +++-                     return t)-        term   = do f <- factor-                    Parse.skipSpaces-                    (do _  <- Parse.string "&&"-                        Parse.skipSpaces-                        t <- term-                        return (IntersectVersionRanges f t)-                     +++-                     return f)-        factor = Parse.choice $ parens expr-                              : parseAnyVersion-                              : parseWildcardRange-                              : map parseRangeOp rangeOps-        parseAnyVersion    = Parse.string "-any" >> return AnyVersion--        parseWildcardRange = do-          _ <- Parse.string "=="-          Parse.skipSpaces-          branch <- Parse.sepBy1 digits (Parse.char '.')-          _ <- Parse.char '.'-          _ <- Parse.char '*'-          return (WildcardVersion (Version branch []))--        parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces)-                                 (Parse.char ')' >> Parse.skipSpaces)-                                 (do a <- p-                                     Parse.skipSpaces-                                     return (VersionRangeParens a))--        digits = do-          first <- Parse.satisfy Char.isDigit-          if first == '0'-            then return 0-            else do rest <- Parse.munch Char.isDigit-                    return (read (first : rest))--        parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse-        rangeOps = [ ("<",  EarlierVersion),-                     ("<=", orEarlierVersion),-                     (">",  LaterVersion),-                     (">=", orLaterVersion),-                     ("==", ThisVersion) ]
LICENSE view
@@ -1,7 +1,8 @@-Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren,-                         Bjorn Bringert, Krasimir Angelov,-                         Malcolm Wallace, Ross Patterson, Ian Lynagh,-                         Duncan Coutts, Thomas Schilling+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.+ All rights reserved.  Redistribution and use in source and binary forms, with or without
− Language/Haskell/Extension.hs 
@@ -1,540 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Language.Haskell.Extension--- Copyright   :  Isaac Jones 2003-2004------ Maintainer  :  libraries@haskell.org--- Portability :  portable------ Haskell language dialects and extensions--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Language.Haskell.Extension (-        Language(..),-        knownLanguages,--        Extension(..),-        KnownExtension(..),-        knownExtensions,-        deprecatedExtensions-  ) where--import Distribution.Text (Text(..))-import qualified Distribution.Compat.ReadP as Parse-import qualified Text.PrettyPrint as Disp-import qualified Data.Char as Char (isAlphaNum)-import Data.Array (Array, accumArray, bounds, Ix(inRange), (!))---- --------------------------------------------------------------- * 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--  -- | An unknown language, identified by its name.-  | UnknownLanguage String-  deriving (Show, Read, Eq)--knownLanguages :: [Language]-knownLanguages = [Haskell98, Haskell2010]--instance Text Language where-  disp (UnknownLanguage other) = Disp.text other-  disp other                   = Disp.text (show other)--  parse = do-    lang <- Parse.munch1 Char.isAlphaNum-    return (classifyLanguage lang)--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, JHC, Hugs, NHC)------ | 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, e.g. \"GHC &#xa7; 7.2.1\" for an extension--- documented in section 7.2.1 of the GHC User's Guide.--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 (Show, Read, Eq)--data KnownExtension =--  -- | [GHC &#xa7; 7.6.3.4] Allow overlapping class instances,-  -- provided there is a unique most specific instance for each use.-    OverlappingInstances--  -- | [GHC &#xa7; 7.6.3.3] Ignore structural rules guaranteeing the-  -- termination of class instance resolution.  Termination is-  -- guaranteed by a fixed-depth recursion stack, and compilation-  -- may fail if this depth is exceeded.-  | UndecidableInstances--  -- | [GHC &#xa7; 7.6.3.4] Implies 'OverlappingInstances'.  Allow the-  -- implementation to choose an instance even when it is possible-  -- that further instantiation of types will lead to a more specific-  -- instance being applicable.-  | IncoherentInstances--  -- | [GHC &#xa7; 7.3.8] Allows recursive bindings in @do@ blocks,-  -- using the @rec@ keyword.-  | DoRec--  -- | [GHC &#xa7; 7.3.8.2] Deprecated in GHC.  Allows recursive bindings-  -- using @mdo@, a variant of @do@.  @DoRec@ provides a different,-  -- preferred syntax.-  | RecursiveDo--  -- | [GHC &#xa7; 7.3.9] Provide syntax for writing list-  -- comprehensions which iterate over several lists together, like-  -- the 'zipWith' family of functions.-  | ParallelListComp--  -- | [GHC &#xa7; 7.6.1.1] Allow multiple parameters in a type class.-  | MultiParamTypeClasses--  -- | [GHC &#xa7; 7.17] Enable the dreaded monomorphism restriction.-  | MonomorphismRestriction--  -- | [GHC &#xa7; 7.6.2] Allow a specification attached to a-  -- multi-parameter type class which indicates that some parameters-  -- are entirely determined by others. The implementation will check-  -- that this property holds for the declared instances, and will use-  -- this property to reduce ambiguity in instance resolution.-  | FunctionalDependencies--  -- | [GHC &#xa7; 7.8.5] Like 'RankNTypes' but does not allow a-  -- higher-rank type to itself appear on the left of a function-  -- arrow.-  | Rank2Types--  -- | [GHC &#xa7; 7.8.5] Allow a universally-quantified type to occur on-  -- the left of a function arrow.-  | RankNTypes--  -- | [GHC &#xa7; 7.8.5] Allow data constructors to have polymorphic-  -- arguments.  Unlike 'RankNTypes', does not allow this for ordinary-  -- functions.-  | PolymorphicComponents--  -- | [GHC &#xa7; 7.4.4] Allow existentially-quantified data constructors.-  | ExistentialQuantification--  -- | [GHC &#xa7; 7.8.7] Cause a type variable in a signature, which has an-  -- explicit @forall@ quantifier, to scope over the definition of the-  -- accompanying value declaration.-  | ScopedTypeVariables--  -- | Deprecated, use 'ScopedTypeVariables' instead.-  | PatternSignatures--  -- | [GHC &#xa7; 7.8.3] Enable implicit function parameters with dynamic-  -- scope.-  | ImplicitParams--  -- | [GHC &#xa7; 7.8.2] Relax some restrictions on the form of the context-  -- of a type signature.-  | FlexibleContexts--  -- | [GHC &#xa7; 7.6.3.2] Relax some restrictions on the form of the-  -- context of an instance declaration.-  | FlexibleInstances--  -- | [GHC &#xa7; 7.4.1] Allow data type declarations with no constructors.-  | EmptyDataDecls--  -- | [GHC &#xa7; 4.10.3] Run the C preprocessor on Haskell source code.-  | CPP--  -- | [GHC &#xa7; 7.8.4] Allow an explicit kind signature giving the kind of-  -- types over which a type variable ranges.-  | KindSignatures--  -- | [GHC &#xa7; 7.11] Enable a form of pattern which forces evaluation-  -- before an attempted match, and a form of strict @let@/@where@-  -- binding.-  | BangPatterns--  -- | [GHC &#xa7; 7.6.3.1] Allow type synonyms in instance heads.-  | TypeSynonymInstances--  -- | [GHC &#xa7; 7.9] Enable Template Haskell, a system for compile-time-  -- metaprogramming.-  | TemplateHaskell--  -- | [GHC &#xa7; 8] Enable the Foreign Function Interface.  In GHC,-  -- implements the standard Haskell 98 Foreign Function Interface-  -- Addendum, plus some GHC-specific extensions.-  | ForeignFunctionInterface--  -- | [GHC &#xa7; 7.10] Enable arrow notation.-  | Arrows--  -- | [GHC &#xa7; 7.16] Enable generic type classes, with default instances-  -- defined in terms of the algebraic structure of a type.-  | Generics--  -- | [GHC &#xa7; 7.3.11] Enable the implicit importing of the module-  -- @Prelude@.  When disabled, when desugaring certain built-in syntax-  -- into ordinary identifiers, use whatever is in scope rather than the-  -- @Prelude@ -- version.-  | ImplicitPrelude--  -- | [GHC &#xa7; 7.3.15] Enable syntax for implicitly binding local names-  -- corresponding to the field names of a record.  Puns bind specific-  -- names, unlike 'RecordWildCards'.-  | NamedFieldPuns--  -- | [GHC &#xa7; 7.3.5] Enable a form of guard which matches a pattern and-  -- binds variables.-  | PatternGuards--  -- | [GHC &#xa7; 7.5.4] Allow a type declared with @newtype@ to use-  -- @deriving@ for any class with an instance for the underlying type.-  | GeneralizedNewtypeDeriving--  -- | [Hugs &#xa7; 7.1] Enable the \"Trex\" extensible records system.-  | ExtensibleRecords--  -- | [Hugs &#xa7; 7.2] Enable type synonyms which are transparent in-  -- some definitions and opaque elsewhere, as a way of implementing -  -- abstract datatypes.-  | RestrictedTypeSynonyms--  -- | [Hugs &#xa7; 7.3] Enable an alternate syntax for string literals,-  -- with string templating.-  | HereDocuments--  -- | [GHC &#xa7; 7.3.2] Allow the character @#@ as a postfix modifier on-  -- identifiers.  Also enables literal syntax for unboxed values.-  | MagicHash--  -- | [GHC &#xa7; 7.7] Allow data types and type synonyms which are-  -- indexed by types, i.e. ad-hoc polymorphism for types.-  | TypeFamilies--  -- | [GHC &#xa7; 7.5.2] Allow a standalone declaration which invokes the-  -- type class @deriving@ mechanism.-  | StandaloneDeriving--  -- | [GHC &#xa7; 7.3.1] Allow certain Unicode characters to stand for-  -- certain ASCII character sequences, e.g. keywords and punctuation.-  | UnicodeSyntax--  -- | [GHC &#xa7; 8.1.1] Allow the use of unboxed types as foreign types,-  -- e.g. in @foreign import@ and @foreign export@.-  | UnliftedFFITypes--  -- | [GHC &#xa7; 7.4.3] Defer validity checking of types until after-  -- expanding type synonyms, relaxing the constraints on how synonyms-  -- may be used.-  | LiberalTypeSynonyms--  -- | [GHC &#xa7; 7.4.2] Allow the name of a type constructor, type class,-  -- or type variable to be an infix operator.-  | TypeOperators----PArr -- not ready yet, and will probably be renamed to ParallelArrays--  -- | [GHC &#xa7; 7.3.16] Enable syntax for implicitly binding local names-  -- corresponding to the field names of a record.  A wildcard binds-  -- all unmentioned names, unlike 'NamedFieldPuns'.-  | RecordWildCards--  -- | Deprecated, use 'NamedFieldPuns' instead.-  | RecordPuns--  -- | [GHC &#xa7; 7.3.14] Allow a record field name to be disambiguated-  -- by the type of the record it's in.-  | DisambiguateRecordFields--  -- | [GHC &#xa7; 7.6.4] Enable overloading of string literals using a-  -- type class, much like integer literals.-  | OverloadedStrings--  -- | [GHC &#xa7; 7.4.6] Enable generalized algebraic data types, in-  -- which type variables may be instantiated on a per-constructor-  -- basis. Implies GADTSyntax.-  | GADTs--  -- | Enable GADT syntax for declaring ordinary algebraic datatypes.-  | GADTSyntax--  -- | [GHC &#xa7; 7.17.2] Make pattern bindings monomorphic.-  | MonoPatBinds--  -- | [GHC &#xa7; 7.8.8] Relax the requirements on mutually-recursive-  -- polymorphic functions.-  | RelaxedPolyRec--  -- | [GHC &#xa7; 2.4.5] Allow default instantiation of polymorphic-  -- types in more situations.-  | ExtendedDefaultRules--  -- | [GHC &#xa7; 7.2.2] Enable unboxed tuples.-  | UnboxedTuples--  -- | [GHC &#xa7; 7.5.3] Enable @deriving@ for classes-  -- @Data.Typeable.Typeable@ and @Data.Generics.Data@.-  | DeriveDataTypeable--  -- | [GHC &#xa7; 7.6.1.3] Allow a class method's type to place-  -- additional constraints on a class type variable.-  | ConstrainedClassMethods--  -- | [GHC &#xa7; 7.3.18] Allow imports to be qualified by the package-  -- name the module is intended to be imported from, e.g.-  ---  -- > import "network" Network.Socket-  | PackageImports--  -- | [GHC &#xa7; 7.8.6] Deprecated in GHC 6.12 and will be removed in-  -- GHC 7.  Allow a type variable to be instantiated at a-  -- polymorphic type.-  | ImpredicativeTypes--  -- | [GHC &#xa7; 7.3.3] Change the syntax for qualified infix-  -- operators.-  | NewQualifiedOperators--  -- | [GHC &#xa7; 7.3.12] Relax the interpretation of left operator-  -- sections to allow unary postfix operators.-  | PostfixOperators--  -- | [GHC &#xa7; 7.9.5] Enable quasi-quotation, a mechanism for defining-  -- new concrete syntax for expressions and patterns.-  | QuasiQuotes--  -- | [GHC &#xa7; 7.3.10] Enable generalized list comprehensions,-  -- supporting operations such as sorting and grouping.-  | TransformListComp--  -- | [GHC &#xa7; 7.3.6] Enable view patterns, which match a value by-  -- applying a function and matching on the result.-  | ViewPatterns--  -- | Allow concrete XML syntax to be used in expressions and patterns,-  -- as per the Haskell Server Pages extension language:-  -- <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--  -- | Enables the use of tuple sections, e.g. @(, True)@ desugars into-  -- @\x -> (x, True)@.-  | TupleSections--  -- | Allows GHC primops, written in C--, to be imported into a Haskell-  -- file.-  | GHCForeignImportPrim--  -- | Support for patterns of the form @n + k@, where @k@ is an-  -- integer literal.-  | NPlusKPatterns--  -- | Improve the layout rule when @if@ expressions are used in a @do@-  -- block.-  | DoAndIfThenElse--  -- | Makes much of the Haskell sugar be desugared into calls to the-  -- function with a particular name that is in scope.-  | RebindableSyntax--  -- | Make @forall@ a keyword in types, which can be used to give the-  -- generalisation explicitly.-  | ExplicitForAll--  -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in-  -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@.-  | DatatypeContexts--  -- | Local (@let@ and @where@) bindings are monomorphic.-  | MonoLocalBinds--  -- | Enable @deriving@ for the @Data.Functor.Functor@ class.-  | DeriveFunctor--  -- | Enable @deriving@ for the @Data.Traversable.Traversable@ class.-  | DeriveTraversable--  -- | Enable @deriving@ for the @Data.Foldable.Foldable@ class.-  | DeriveFoldable--  -- | Enable non-decreasing indentation for 'do' blocks.-  | NondecreasingIndentation--  -- | [GHC &#xa7; 7.20.3] Allow imports to be qualified with a safe-  -- keyword that requires the imported module be trusted as according-  -- to the Safe Haskell definition of trust.-  ---  -- > import safe Network.Socket-  | SafeImports--  -- | [GHC &#xa7; 7.20] Compile a module in the Safe, Safe Haskell-  -- mode -- a restricted form of the Haskell language to ensure-  -- type safety.-  | Safe--  -- | [GHC &#xa7; 7.20] Compile a module in the Trustworthy, Safe-  -- Haskell mode -- no restrictions apply but the module is marked-  -- as trusted as long as the package the module resides in is-  -- trusted.-  | Trustworthy--  -- | [GHC &#xa7; 7.40] Allow type class/implicit parameter/equality-  -- constraints to be used as types with the special kind Constraint.-  -- Also generalise the (ctxt => ty) syntax so that any type of kind-  -- Constraint can occur before the arrow.-  | ConstraintKinds--  deriving (Show, Read, Eq, Enum, Bounded)--{-# DEPRECATED knownExtensions-   "KnownExtension is an instance of Enum and Bounded, use those instead." #-}-knownExtensions :: [KnownExtension]-knownExtensions = [minBound..maxBound]---- | 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 recomend 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 Text Extension where-  disp (UnknownExtension other) = Disp.text other-  disp (EnableExtension ke)     = Disp.text (show ke)-  disp (DisableExtension ke)    = Disp.text ("No" ++ show ke)--  parse = do-    extension <- Parse.munch1 Char.isAlphaNum-    return (classifyExtension extension)--instance Text KnownExtension where-  disp ke = Disp.text (show ke)--  parse = do-    extension <- Parse.munch1 Char.isAlphaNum-    case classifyKnownExtension extension of-        Just ke ->-            return ke-        Nothing ->-            fail ("Can't parse " ++ show extension ++ " as KnownExtension")--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')-    [ (head str, (str, extension))-    | extension <- [toEnum 0 ..]-    , let str = show extension ]-
− README 
@@ -1,168 +0,0 @@-The Cabal library package-=========================--[Cabal home page](http://www.haskell.org/cabal/)--If you also want the `cabal` command line program then you need-the `cabal-install` package in addition to this library.---Installation instructions for the Cabal library-===============================================--Installing as a user (no root or administer access)------------------------------------------------------    ghc --make Setup-    ./Setup configure --user-    ./Setup build-    ./Setup install--Note the use of the `--user` flag at the configure step.--Compiling Setup rather than using `runghc Setup` is much faster and works on-Windows. For all packages other than Cabal itself it is fine to use `runghc`.--This will install into `$HOME/.cabal/` on unix and into-`$Documents and Settings\$User\Application Data\cabal\` on Windows-If you want to install elsewhere use the `--prefix=` flag at the-configure step.---Installing as root / Administrator-------------------------------------    ghc --make Setup-    ./Setup configure-    ./Setup build-    sudo ./Setup install--Compiling Setup rather than using `runghc Setup` is much faster and works on-Windows. For all packages other than Cabal itself it is fine to use `runghc`.--This will install into `/usr/local` on unix and on Windows it will-install into `$ProgramFiles/Haskell`. If you want to install-elsewhere use the `--prefix=` flag at the configure step.---Working with older versions of GHC and Cabal-============================================--It is recommended just to leave any pre-existing version of Cabal-installed. In particular it is *essential* to keep the version that-came with GHC itself since other installed packages need it (eg the-"ghc" api package).--Prior to GHC 6.4.2 however, GHC didn't deal particularly well with-having multiple versions of packages installed at once. So if you-are using GHC 6.4.1 or older and you have an older version of Cabal-installed, you probably just want to remove it:--    ghc-pkg unregister Cabal--or if you had Cabal installed just for your user account then:--    ghc-pkg unregister Cabal --user---The `filepath` dependency-=========================--Cabal now uses the `filepath` package so that must be installed first.-GHC-6.6.1 and later come with `filepath` however earlier versions do not by-default. If you do not already have `filepath` then you need to install it. You-can use any existing version of Cabal to do that. If you have neither Cabal or-filepath then it is slightly harder but still possible.--Unpack Cabal and filepath into separate directories. For example:--    tar -xzf filepath-1.1.0.0.tar.gz-    tar -xzf Cabal-1.6.0.0.tar.gz--    # rename to make the following instructions simpler:-    mv filepath-1.1.0.0/ filepath/-    mv Cabal-1.6.0.0/ Cabal/--    cd Cabal-    ghc -i../filepath -cpp --make Setup.hs -o ../filepath/setup-    cd ../filepath/-    ./setup configure --user-    ./setup build-    ./setup install--This installs filepath so you are then in a position to install Cabal by the-normal method.---More Information-================--Please see the web site for the [user guide] and API documentation.-There is some more information available on the [development wiki].--[user guide]:       http://www.haskell.org/cabal/-[development wiki]: http://hackage.haskell.org/trac/hackage/---Bugs-=======--Please report bugs and wish-list items in our [bug tracker].--[bug tracker]: http://hackage.haskell.org/trac/hackage/---Your Help------------To help us in the next round of development work it would be-enormously helpful to know from our users what their most pressing-problems are with Cabal and Hackage. You probably have a favourite-Cabal bug or limitation. Take a look at our [bug tracker]. Make sure-the problem is reported there and properly described. Comment on the-ticket to tell us how much of a problem the bug is for you. Add-yourself to the ticket's cc list so we can discuss requirements and-keep you informed on progress. For feature requests it is very-helpful if there is a description of how you would expect to-interact with the new feature.---Code-=======--You can get the code from the web page; the version control system we-use is very open and welcoming to new developers.--You can get the main development branch:--> darcs get --partial http://darcs.haskell.org/cabal--and you can get the stable 1.6 branch:--> darcs get --partial http://darcs.haskell.org/cabal-branches/cabal-1.6---Credits-=======--Cabal Coders (in alphabetical order):--- Krasimir Angelov-- Bjorn Bringert-- Duncan Coutts-- Isaac Jones-- David Himmelstrup (Lemmih)-- Simon Marlow-- Ross Patterson-- Thomas Schilling-- Martin Sjögren-- Malcolm Wallace-- and nearly 30 other people have contributed occasional patches--Cabal spec:--- Isaac Jones-- Simon Marlow-- Ross Patterson-- Simon Peyton Jones-- Malcolm Wallace
+ README.md view
@@ -0,0 +1,69 @@+The Cabal library package+=========================++See the [Cabal web site] for more information.++If you also want the `cabal` command-line program, you need the+[cabal-install] package in addition to this library.++[cabal-install]: ../cabal-install++More information+================++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]: https://hackage.haskell.org/package/Cabal/docs/Distribution-Simple.html+[development wiki]:  https://github.com/haskell/cabal/wiki+++Bugs+====++Please report bugs and feature requests to Cabal's [bug tracker].+++Your help+---------++To help Cabal's development, it is enormously helpful to know from+Cabal's users what their most pressing problems are with Cabal and+[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 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.++[Hackage]: http://hackage.haskell.org+++Source code+===========++You can get the master development branch using:++    $ git clone https://github.com/haskell/cabal.git+++Credits+=======++See the `AUTHORS` file.++Authors of the [original Cabal+specification](https://www.haskell.org/cabal/proposal/pkg-spec.pdf):++- Isaac Jones+- Simon Marlow+- Ross Patterson+- Simon Peyton Jones+- Malcolm Wallace+++[bug tracker]: https://github.com/haskell/cabal/issues+[Cabal web site]: http://www.haskell.org/cabal/
Setup.hs view
@@ -1,4 +1,5 @@ import Distribution.Simple+ main :: IO () main = defaultMain @@ -8,3 +9,6 @@ -- on any previous installation. This also means we can use any new features -- immediately because we never have to worry about building Cabal with an -- older version of itself.+--+-- NOTE 25/01/2015: Bootstrapping is disabled for now, see+-- https://github.com/haskell/cabal/issues/3003.
− changelog 
@@ -1,385 +0,0 @@--*-change-log-*---1.11.x (current development version)--1.10.0.x (next stable release version)--1.10.2.0 Duncan Coutts <duncan@community.haskell.org> June 2011-	* Include test suites in cabal sdist-	* Fix for conditionals in test suite stanzas in .cabal files-	* Fix permissions of directories created during install-	* Fix for global builds when $HOME env var is not set--1.10.1.0 Duncan Coutts <duncan@community.haskell.org> February 2011-	* Improved error messages when test suites are not enabled-	* Template parameters allowed in test --test-option(s) flag-	* Improved documentation of the test feature-	* Relaxed QA check on cabal-version when using test-suite sections-	* haddock command now allows both --hoogle and --html at the same time-	* Find ghc-version-specific instances of the hsc2hs program-	* Preserve file executable permissions in sdist tarballs-	* Pass gcc location and flags to ./configure scripts-	* Get default gcc flags from ghc--1.10.0.0 Duncan Coutts <duncan@haskell.org> November 2010-	* New cabal test feature-	* Initial support for UHC-	* New default-language and other-languages fields (e.g. Haskell98/2010)-	* New default-extensions and other-extensions fields-	* Deprecated extensions field (for packages using cabal-version >=1.10)-	* Cabal-version field must now only be of the form ">= x.y"-	* Removed deprecated --copy-prefix= feature-	* Auto-reconfigure when .cabal file changes-	* Workaround for haddock overwriting .hi and .o files when using TH-	* Extra cpp flags used with hsc2hs and c2hs (-D${os}_BUILD_OS etc)-	* New cpp define VERSION_<package> gives string version of dependencies-	* User guide source now in markdown format for easier editing-	* Improved checks and error messages for C libraries and headers-	* Removed BSD4 from the list of suggested licenses-	* Updated list of known language extensions-	* Fix for include paths to allow C code to import FFI stub.h files-	* Fix for intra-package dependencies on OSX-	* Stricter checks on various bits of .cabal file syntax-	* Minor fixes for c2hs--1.8.0.6 Duncan Coutts <duncan@haskell.org> June 2010-	* Fix 'register --global/--user'--1.8.0.4 Duncan Coutts <duncan@haskell.org> March 2010-	* Set dylib-install-name for dynalic libs on OSX-	* Stricter configure check that compiler supports a package's extensions-	* More configure-time warnings-	* Hugs can compile Cabal lib again-	* Default datadir now follows prefix on Windows-	* Support for finding installed packages for hugs-	* Cabal version macros now have proper parenthesis-	* Reverted change to filter out deps of non-buildable components-	* Fix for registering implace when using a specific package db-	* Fix mismatch between $os and $arch path template variables-	* Fix for finding ar.exe on Windows, always pick ghc's version-	* Fix for intra-package dependencies with ghc-6.12--1.8.0.2 Duncan Coutts <duncan@haskell.org> December 2009-	* Support for GHC-6.12-	* New unique installed package IDs which use a package hash-	* Allow executables to depend on the lib within the same package-	* Dependencies for each component apply only to that component-	  (previously applied to all the other components too)-	* Added new known license MIT and versioned GPL and LGPL-	* More liberal package version range syntax-	* Package registration files are now UTF8-	* Support for LHC and JHC-0.7.2-	* Deprecated RecordPuns extension in favour of NamedFieldPuns-	* Deprecated PatternSignatures extension in favor of ScopedTypeVariables-	* New VersionRange semantic view as a sequence of intervals-	* Improved package quality checks-	* Minor simplification in a couple Setup.hs hooks-	* Beginnings of a unit level testsuite using QuickCheck-	* Various bug fixes-	* Various internal cleanups--1.6.0.2 Duncan Coutts <duncan@haskell.org> February 2009-	* New configure-time check for C headers and libraries-	* Added language extensions present in ghc-6.10-	* Added support for NamedFieldPuns extension in ghc-6.8-	* Fix in configure step for ghc-6.6 on Windows-	* Fix warnings in Path_pkgname.hs module on Windows-	* Fix for exotic flags in ld-options field-	* Fix for using pkg-config in a package with a lib and an executable-	* Fix for building haddock docs for exes that use the Paths module-	* Fix for installing header files in subdirectories-	* Fix for the case of building profiling libs but not ordinary libs-	* Fix read-only attribute of installed files on Windows-	* Ignore ghc -threaded flag when profiling in ghc-6.8 and older--1.6.0.1 Duncan Coutts <duncan@haskell.org> October 2008-	* Export a compat function to help alex and happy--1.6.0.0 Duncan Coutts <duncan@haskell.org> October 2008-	* Support for ghc-6.10-	* Source control repositories can now be specified in .cabal files-	* Bug report URLs can be now specified in .cabal files-	* Wildcards now allowed in data-files and extra-source-files fields-	* New syntactic sugar for dependencies "build-depends: foo ==1.2.*"-	* New cabal_macros.h provides macros to test versions of dependencies-	* Relocatable bindists now possible on unix via env vars-	* New 'exposed' field allows packages to be not exposed by default-	* Install dir flags can now use $os and $arch variables-	* New --builddir flag allows multiple builds from a single sources dir-	* cc-options now only apply to .c files, not for -fvia-C-	* cc-options are not longer propagated to dependent packages-	* The cpp/cc/ld-options fields no longer use ',' as a separator-	* hsc2hs is now called using gcc instead of using ghc as gcc-	* New api for manipulating sets and graphs of packages-	* Internal api improvements and code cleanups-	* Minor improvements to the user guide-	* Miscellaneous minor bug fixes--1.4.0.2 Duncan Coutts <duncan@haskell.org> August 2008-	* Fix executable stripping default-	* Fix striping exes on OSX that export dynamic symbols (like ghc)-	* Correct the order of arguments given by --prog-options=-	* Fix corner case with overlapping user and global packages-	* Fix for modules that use pre-processing and .hs-boot files-	* Clarify some points in the user guide and readme text-	* Fix verbosity flags passed to sub-command like haddock-	* Fix sdist --snapshot-	* Allow meta-packages that contain no modules or C code-	* Make the generated Paths module -Wall clean on Windows--1.4.0.1 Duncan Coutts <duncan@haskell.org> June 2008-	* Fix a bug which caused '.' to always be in the sources search path-	* Haddock-2.2 and later do now support the --hoogle flag--1.4.0.0 Duncan Coutts <duncan@haskell.org> June 2008-	* Rewritten command line handling support-	* Command line completion with bash-	* Better support for Haddock 2-	* Improved support for nhc98-	* Removed support for ghc-6.2-	* Haddock markup in .lhs files now supported-	* Default colour scheme for highlighted source code-	* Default prefix for --user installs is now $HOME/.cabal-	* All .cabal files are treaded as UTF-8 and must be valid-	* 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"-	* Improved user guide introduction-	* Programatica support removed-	* New options --program-prefix/suffix allows eg versioned programs-	* Support packages that use .hs-boot files-	* Fix sdist for Main modules that require preprocessing-	* New configure -O flag with optimisation level 0--2-	* Provide access to "x-" extension fields through the Cabal api-	* Added check for broken installed packages-	* Added warning about using inconsistent versions of dependencies-	* Strip binary executable files by default with an option to disable-	* New options to add site-specific include and library search paths-	* Lift the restriction that libraries must have exposed-modules-	* Many bugs fixed.-	* Many internal structural improvements and code cleanups--1.2.4.0 Duncan Coutts <duncan@haskell.org> June 2008-	* Released with GHC 6.8.3-	* Backported several fixes and minor improvements from Cabal-1.4-	* Use a default colour scheme for sources with hscolour >=1.9-	* Support --hyperlink-source for Haddock >= 2.0-	* Fix for running in a non-writable directory-	* Add OSX -framework arguments when linking executables-	* Updates to the user guide-	* Allow build-tools names to include + and _-	* Export autoconfUserHooks and simpleUserHooks-	* Export ccLdOptionsBuildInfo for Setup.hs scripts-	* Export unionBuildInfo and make BuildInfo an instance of Monoid-	* Fix to allow the 'main-is' module to use a pre-processor--1.2.3.0 Duncan Coutts <duncan@haskell.org> Nov 2007-	* Released with GHC 6.8.2-	* Includes full list of GHC language extensions-	* Fix infamous "dist/conftest.c" bug-	* Fix configure --interfacedir=-	* Find ld.exe on Windows correctly-	* Export PreProcessor constructor and mkSimplePreProcessor-	* Fix minor bug in unlit code-	* Fix some markup in the haddock docs--1.2.2.0 Duncan Coutts <duncan@haskell.org> Nov 2007-	* Released with GHC 6.8.1-	* Support haddock-2.0-	* Support building DSOs with GHC-	* Require reconfiguring if the .cabal file has changed-	* Fix os(windows) configuration test-	* Fix building documentation-	* Fix building packages on Solaris-	* Other minor bug fixes--1.2.1 Duncan Coutts <duncan@haskell.org> Oct 2007-	* To be included in GHC 6.8.1-	* New field "cpp-options" used when preprocessing Haskell modules-	* Fixes for hsc2hs when using ghc-	* C source code gets compiled with -O2 by default-	* OS aliases, to allow os(windows) rather than requiring os(mingw32)-	* Fix cleaning of 'stub' files-	* Fix cabal-setup, command line ui that replaces "runhaskell Setup.hs"-	* Build docs even when dependent packages docs are missing-	* Allow the --html-dir to be specified at configure time-	* Fix building with ghc-6.2-	* Other minor bug fixes and build fixes--1.2.0  Duncan Coutts <duncan.coutts@worc.ox.ac.uk> Sept 2007-	* To be included in GHC 6.8.x-	* New configurations feature-	* Can make haddock docs link to hilighted sources (with hscolour)-	* New flag to allow linking to haddock docs on the web-	* Supports pkg-config-	* New field "build-tools" for tool dependencies-	* Improved c2hs support-	* Preprocessor output no longer clutters source dirs-	* Seperate "includes" and "install-includes" fields-	* Makefile command to generate makefiles for building libs with GHC-	* New --docdir configure flag-	* Generic --with-prog --prog-args configure flags-	* Better default installation paths on Windows-	* Install paths can be specified relative to each other-	* License files now installed-	* Initial support for NHC (incomplete)-	* Consistent treatment of verbosity-	* Reduced verbosity of configure step by default-	* Improved helpfulness of output messages-	* Help output now clearer and fits in 80 columns-	* New setup register --gen-pkg-config flag for distros-	* Major internal refactoring, hooks api has changed-	* Dozens of bug fixes--1.1.6.2 Duncan Coutts <duncan.coutts@worc.ox.ac.uk> May 2007-	* Released with GHC 6.6.1-	* Handle windows text file encoding for .cabal files-	* Fix compiling a executable for profiling that uses Template Haskell-	* Other minor bug fixes and user guide clarifications--1.1.6.1 Duncan Coutts <duncan.coutts@worc.ox.ac.uk> Oct 2006-	* fix unlit code-	* fix escaping in register.sh--1.1.6  Duncan Coutts <duncan.coutts@worc.ox.ac.uk> Oct 2006-	* Released with GHC 6.6-	* Added support for hoogle-	* Allow profiling and normal builds of libs to be chosen indepentantly-	* Default installation directories on Win32 changed-	* Register haddock docs with ghc-pkg-	* Get haddock to make hyperlinks to dependent package docs-	* Added BangPatterns language extension-	* Various bug fixes--1.1.4  Duncan Coutts <duncan.coutts@worc.ox.ac.uk> May 2006-	* Released with GHC 6.4.2-	* Better support for packages that need to install header files-	* cabal-setup added, but not installed by default yet-	* Implemented "setup register --inplace"-	* Have packages exposed by default with ghc-6.2-	* It is no longer necessary to run 'configure' before 'clean' or 'sdist'-	* Added support for ghc's -split-objs-	* Initial support for JHC-	* Ignore extension fields in .cabal files (fields begining with "x-")-	* Some changes to command hooks API to improve consistency-	* Hugs support improvements-	* Added GeneralisedNewtypeDeriving language extension-	* Added cabal-version field-	* Support hidden modules with haddock-	* Internal code refactoring-	* More bug fixes--1.1.3  Isaac Jones  <ijones@syntaxpolice.org> Sept 2005-	* WARNING: Interfaces not documented in the user's guide may-	  change in future releases.-	* Move building of GHCi .o libs to the build phase rather than-	register phase. (from Duncan Coutts)-	* Use .tar.gz for source package extension-	* Uses GHC instead of cpphs if the latter is not available-	* Added experimental "command hooks" which completely override the-	default behavior of a command.-	* Some bugfixes--1.1.1  Isaac Jones  <ijones@syntaxpolice.org> July 2005-	* WARNING: Interfaces not documented in the user's guide may-	  change in future releases.- 	* Handles recursive modules for GHC 6.2 and GHC 6.4.-	* Added "setup test" command (Used with UserHook)-	* implemented handling of _stub.{c,h,o} files-	* Added support for profiling-	* Changed install prefix of libraries (pref/pkgname-version-	  to prefix/pkgname-version/compname-version)-	* Added pattern guards as a language extension-	* Moved some functionality to Language.Haskell.Extension-	* Register / unregister .bat files for windows-	* Exposed more of the API-	* Added support for the hide-all-packages flag in GHC > 6.4-	* Several bug fixes--1.0  Isaac Jones  <ijones@syntaxpolice.org> March 11 2005-	* Released with GHC 6.4, Hugs March 2005, and nhc98 1.18-	* Some sanity checking--0.5  Isaac Jones  <ijones@syntaxpolice.org> Wed Feb 19 2005-	* WARNING: this is a pre-release and the interfaces are still-	likely to change until we reach a 1.0 release.-	* Hooks interfaces changed-	* Added preprocessors to user hooks-	* No more executable-modules or hidden-modules.  Use-	"other-modules" instead.-	* Certain fields moved into BuildInfo, much refactoring-	* extra-libs -> extra-libraries-	* Added --gen-script to configure and unconfigure.-	* modules-ghc (etc) now ghc-modules (etc)-	* added new fields including "synopsis"-	* Lots of bug fixes-	* spaces can sometimes be used instead of commas-	* A user manual has appeared (Thanks, ross!)-	* for ghc 6.4, configures versionsed depends properly-	* more features to ./setup haddock--0.4  Isaac Jones  <ijones@syntaxpolice.org> Sun Jan 16 2005--	* Much thanks to all the awesome fptools hackers who have been-	working hard to build the Haskell Cabal!--	* Interface Changes:--	** WARNING: this is a pre-release and the interfaces are still-	likely to change until we reach a 1.0 release.--	** Instead of Package.description, you should name your-	description files <something>.cabal.  In particular, we suggest-	that you name it <packagename>.cabal, but this is not enforced-	(yet).  Multiple .cabal files in the same directory is an error,-	at least for now.--	** ./setup install --install-prefix is gone.  Use ./setup copy-	--copy-prefix instead.--	** The "Modules" field is gone.  Use "hidden-modules",-	"exposed-modules", and "executable-modules".--	** Build-depends is now a package-only field, and can't go into-	executable stanzas.  Build-depends is a package-to-package-	relationship.--	** Some new fields.  Use the Source.--	* New Features--	** Cabal is now included as a package in the CVS version of-	fptools.  That means it'll be released as "-package Cabal" in-	future versions of the compilers, and if you are a bleeding-edge-	user, you can grab it from the CVS repository with the compilers.--	** Hugs compatibility and NHC98 compatibility should both be-	improved.--	** Hooks Interface / Autoconf compatibility: Most of the hooks-	interface is hidden for now, because it's not finalized.  I have-	exposed only "defaultMainWithHooks" and "defaultUserHooks".  This-	allows you to use a ./configure script to preprocess-	"foo.buildinfo", which gets merged with "foo.cabal".  In future-	releases, we'll expose UserHooks, but we're definitely going to-	change the interface to those.  The interface to the two functions-	I've exposed should stay the same, though.--	** ./setup haddock is a baby feature which pre-processes the-	source code with hscpp and runs haddock on it.  This is brand new-	and hardly tested, so you get to knock it around and see what you-	think.--	** Some commands now actually implement verbosity.--	** The preprocessors have been tested a bit more, and seem to work-	OK.  Please give feedback if you use these.--0.3  Isaac Jones  <ijones@syntaxpolice.org> Sun Jan 16 2005-	* Unstable snapshot release-	* From now on, stable releases are even.--0.2  Isaac Jones  <ijones@syntaxpolice.org>--	* Adds more HUGS support and preprocessor support.
+ src/Distribution/Backpack/ComponentsGraph.hs view
@@ -0,0 +1,105 @@+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.ComponentsGraph+  ( ComponentsGraph+  , ComponentsWithDeps+  , mkComponentsGraph+  , componentsGraphToList+  , dispComponentsWithDeps+  , componentCycleMsg+  ) where++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.Utils.Generic++import Distribution.Pretty (pretty)+import Text.PrettyPrint++------------------------------------------------------------------------------+-- Components graph+------------------------------------------------------------------------------++-- | 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+    ]++-- | Create a 'Graph' of 'Component', or report a cycle if there is a+-- problem.+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]+  where+    -- The dependencies for the given component+    componentDeps component =+      toolDependencies ++ libDependencies+      where+        bi = componentBuildInfo component++        toolDependencies = CExeName <$> getAllInternalToolDependencies pkg_descr bi++        libDependencies = do+          Dependency pkgname _ lns <- targetBuildDepends bi+          guard (pkgname == packageName pkg_descr)++          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 =+  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)+          ]+      )
+ src/Distribution/Backpack/Configure.hs view
@@ -0,0 +1,466 @@+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonoLocalBinds #-}++-- | 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++import Distribution.Compat.Prelude hiding ((<>))+import Prelude ()++import Distribution.Backpack+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.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.ModuleName+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.ComponentInclude+import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.MungedPackageName+import Distribution.Utils.LogProgress+import Distribution.Verbosity++import Data.Either+  ( lefts+  )+import qualified Data.Map as Map+import qualified Data.Set as Set+import Distribution.Pretty+import Text.PrettyPrint++------------------------------------------------------------------------------+-- Pipeline+------------------------------------------------------------------------------++configureComponentLocalBuildInfos+  :: 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, 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)++    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+            [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg))+            | pkg <- prePkgDeps+            ]+            `Map.union` Map.fromList+              [ ( ann_id aid+                ,+                  ( DefiniteUnitId+                      ( unsafeMkDefUnitId+                          (mkUnitId (unComponentId (ann_id aid)))+                      )+                  , emptyModuleShape+                  )+                )+              | 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+        (not (null promisedPkgDeps))+        uid_lookup+        (package pkg_descr)+        shape_pkg_map+        graph1++    infoProgress $+      hang+        (text "Linked component graph:")+        4+        (vcat (map dispLinkedComponent graph2))++    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)+                    ]+                 ]+        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))++    toComponentLocalBuildInfos comp installedPackageSet promisedPkgDeps pkg_descr prePkgDeps graph4++------------------------------------------------------------------------------+-- ComponentLocalBuildInfo+------------------------------------------------------------------------------++toComponentLocalBuildInfos+  :: Compiler+  -> InstalledPackageIndex -- FULL set+  -> [ConfiguredPromisedComponent]+  -> PackageDescription+  -> [PreExistingComponent] -- external package deps+  -> [ReadyComponent]+  -> LogProgress+      ( [ComponentLocalBuildInfo]+      , InstalledPackageIndex -- only relevant packages+      )+toComponentLocalBuildInfos+  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++    case Graph.broken fullIndex of+      [] -> return ()+      -- If there are promised dependencies, we don't know what the dependencies+      -- of these are and that can easily lead to a broken graph. So assume that+      -- any promised package is not broken (ie all its dependencies, transitively,+      -- will be there). That's a promise.+      broken+        | not (null promisedPkgDeps) -> return ()+        | otherwise ->+            -- TODO: ppr this+            dieProgress . text $+              "The following packages are broken because other"+                ++ " packages they depend on are missing. These broken "+                ++ "packages must be rebuilt before they can be used.\n"+                -- TODO: Undupe.+                ++ unlines+                  [ "installed package "+                    ++ prettyShow (packageId pkg)+                    ++ " is broken due to missing package "+                    ++ intercalate ", " (map prettyShow deps)+                  | (Left pkg, deps) <- broken+                  ]+                ++ unlines+                  [ "planned package "+                    ++ prettyShow (packageId pkg)+                    ++ " is broken due to missing package "+                    ++ intercalate ", " (map prettyShow deps)+                  | (Right pkg, deps) <- broken+                  ]++    -- In this section, we'd like to look at the 'packageDependsIndex'+    -- and see if we've picked multiple versions of the same+    -- installed package (this is bad, because it means you might+    -- get an error could not match foo-0.1:Type with foo-0.2:Type).+    --+    -- What is pseudoTopPkg for? I have no idea.  It was used+    -- in the very original commit which introduced checking for+    -- inconsistencies 5115bb2be4e13841ea07dc9166b9d9afa5f0d012,+    -- and then moved out of PackageIndex and put here later.+    -- TODO: Try this code without it...+    --+    -- TODO: Move this into a helper function+    --+    -- 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+            }+    case PackageIndex.dependencyInconsistencies+      . 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+                ]+            )+    let clbis = mkLinkedComponentsLocalBuildInfo comp graph+    -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps)+    return (clbis, packageDependsIndex)++-- Build ComponentLocalBuildInfo for each component we are going+-- to build.+--+-- This conversion is lossy; we lose some invariants from ReadyComponent+mkLinkedComponentsLocalBuildInfo+  :: 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 =+                -- 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 =+                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+           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)) $+            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)
+ src/Distribution/Backpack/ConfiguredComponent.hs view
@@ -0,0 +1,349 @@+-- | 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++import Distribution.Compat.Prelude hiding ((<>))+import Prelude ()++import Distribution.Backpack.Id++import Distribution.CabalSpecVersion+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Simple.BuildToolDepends+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 Control.Monad+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Distribution.Compat.NonEmptySet as NonEmptySet+import Distribution.Pretty+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+  { 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+cc_cid = ann_id . cc_ann_id++-- | The package this component came from.+cc_pkgid :: ConfiguredComponent -> PackageId+cc_pkgid = ann_pid . cc_ann_id++-- | The 'ComponentName' of a component; this uniquely identifies+-- a fragment of syntax within a specified Cabal file describing the+-- component.+cc_name :: ConfiguredComponent -> ComponentName+cc_name = ann_cname . cc_ann_id++-- | Pretty-print a 'ConfiguredComponent'.+dispConfiguredComponent :: ConfiguredComponent -> Doc+dispConfiguredComponent cc =+  hang+    (text "component" <+> pretty (cc_cid cc))+    4+    ( vcat+        [ hsep $+          [ text "include"+          , pretty (ci_id incl)+          , pretty (ci_renaming incl)+          ]+        | incl <- cc_includes cc+        ]+    )++-- | 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+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+        }++  -- 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+      }+  where+    bi :: BuildInfo+    bi = componentBuildInfo component++    prettyLN :: LibraryName -> Doc+    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+        ]++    is_public = componentName component == CLibName LMainLibName++type ConfiguredComponentMap =+  Map PackageName (Map ComponentName (AnnotatedId ComponentId))++toConfiguredComponent+  :: 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+            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 (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.+    -- We want all the public libraries (dep_cn == CLibName)+    -- of all external deps (dep /= pn).  Note that this+    -- excludes the public library of the current package:+    -- 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+      ]+    -- 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+        | ExeDependency pn cn _ <- getAllToolDependencies pkg_descr bi+        , -- 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]+        ]++-- | 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+        ]++extendConfiguredComponentMap+  :: ConfiguredComponent+  -> ConfiguredComponentMap+  -> ConfiguredComponentMap+extendConfiguredComponentMap 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+-- based on internal package dependencies, so that any internal+-- dependency points to an entry earlier in the list.+--+-- TODO: This function currently restricts the input configured components to+-- one version per package, by using the type ConfiguredComponentMap.  It cannot+-- 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]+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+        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+-- specified is >= a certain minimum. Otherwise, for compatibility we use the+-- old behaviour.+newPackageDepsBehaviour :: PackageDescription -> Bool+newPackageDepsBehaviour pkg =+  specVersion pkg >= newPackageDepsBehaviourMinVersion
+ src/Distribution/Backpack/DescribeUnitId.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Rank2Types #-}++module Distribution.Backpack.DescribeUnitId where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Compat.Stack+import Distribution.ModuleName+import Distribution.Pretty+import Distribution.Simple.Utils+import Distribution.Types.ComponentName+import Distribution.Types.PackageId+import Distribution.Verbosity++import Text.PrettyPrint++-- Unit identifiers have a well defined, machine-readable format,+-- but this format isn't very user-friendly for users.  This+-- module defines some functions for solving common rendering+-- problems one has for displaying these.+--+-- There are three basic problems we tackle:+--+--  - Users don't want to see pkg-0.5-inplace-libname,+--    they want to see "library 'libname' from 'pkg-0.5'"+--+--  - Users don't want to see the raw component identifier, which+--    usually contains a wordy hash that doesn't matter.+--+--  - Users don't want to see a hash of the instantiation: they+--    want to see the actual instantiation, and they want it in+--    interpretable form.+--++-- | 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' 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+  where+    msg_doc = text msg <+> text (showComponentName cname)+    for_doc = text "for" <+> pretty pkgid <<>> text "..."
+ src/Distribution/Backpack/FullUnitId.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Backpack.FullUnitId+  ( FullUnitId (..)+  , FullDb+  , expandOpenUnitId+  , expandUnitId+  ) where++import Distribution.Backpack+import Distribution.Compat.Prelude+import Distribution.Types.ComponentId++-- Unlike OpenUnitId, which could direct to a UnitId.+data FullUnitId = FullUnitId ComponentId OpenModuleSubst+  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++expandUnitId :: FullDb -> DefUnitId -> FullUnitId+expandUnitId db uid = db uid
+ src/Distribution/Backpack/Id.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE FlexibleInstances #-}+{-# 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++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.PackageDescription+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.MungedPackageName+import Distribution.Types.UnitId+import Distribution.Utils.Base62+import Distribution.Version++import Distribution.Parsec (simpleParsec)+import Distribution.Pretty+  ( 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+computeComponentId deterministic mb_ipid mb_cid pid cname mb_details =+  -- show is found to be faster than intercalate and then replacement of+  -- special character used in intercalating. We cannot simply hash by+  -- doubly concatenating list, as it just flatten out the nested list, so+  -- different sources can produce same hash+  let hash_suffix+        | Just (dep_ipids, flags) <- mb_details =+            "-"+              ++ hashToBase62+                -- 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)+          )+        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.+-- However, prior to GHC 8.0 there are some restrictions on what+-- format this string can be (due to how ghc-pkg parsed the key):+--+--      1. In GHC 7.10, the string had either be of the form+--      foo_ABCD, where foo is a non-semantic alphanumeric/hyphenated+--      prefix and ABCD is two base-64 encoded 64-bit integers,+--      or a GHC 7.8 style identifier.+--+--      2. In GHC 7.8, the string had to be a valid package identifier+--      like foo-0.1.+--+-- So, the problem is that Cabal, in general, has a general IPID,+-- but needs to figure out a package key / package ID that the+-- old ghc-pkg will actually accept.  But there's an EVERY WORSE+-- problem: if ghc-pkg decides to parse an identifier foo-0.1-xxx+-- as if it were a package identifier, which means it will SILENTLY+-- DROP the "xxx" (because it's a tag, and Cabal does not allow tags.)+-- So we must CONNIVE to ensure that we don't pick something that+-- looks like this.+--+-- So this function attempts to define a mapping into the old formats.+--+-- The mapping for GHC 7.8 and before:+--+--      * We use the *compatibility* package name and version.  For+--        public libraries this is just the package identifier; for+--        internal libraries, it's something like "z-pkgname-z-libname-0.1".+--        See 'computeCompatPackageName' for more details.+--+-- The mapping for GHC 7.10:+--+--      * For CLibName:+--          If the IPID is of the form foo-0.1-ABCDEF where foo_ABCDEF would+--          validly parse as a package key, we pass "ABCDEF".  (NB: not+--          all hashes parse this way, because GHC 7.10 mandated that+--          these hashes be two base-62 encoded 64 bit integers),+--          but hashes that Cabal generated using 'computeComponentId'+--          are guaranteed to have this form.+--+--          If it is not of this form, we rehash the IPID into the+--          correct form and pass that.+--+--      * For sub-components, we rehash the IPID into the correct format+--        and pass that.+computeCompatPackageKey+  :: 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
+ src/Distribution/Backpack/LinkedComponent.hs view
@@ -0,0 +1,486 @@+{-# 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++import Distribution.Compat.Prelude hiding ((<>))+import Prelude ()++import Distribution.Backpack+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.UnifyM+import Distribution.Utils.MapAccum++import Distribution.ModuleName+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Simple.LocalBuildInfo+import Distribution.Types.AnnotatedId+import Distribution.Types.ComponentInclude+import Distribution.Utils.LogProgress+import Distribution.Verbosity++import qualified Data.Map as Map+import qualified Data.Set as Set+import Distribution.Pretty (pretty)+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+  { 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'.+lc_cid :: LinkedComponent -> ComponentId+lc_cid = ann_id . lc_ann_id++-- | Corresponds to 'cc_pkgid'.+lc_pkgid :: LinkedComponent -> PackageId+lc_pkgid = ann_pid . lc_ann_id++-- | The 'OpenUnitId' of this component in the "default" instantiation.+-- See also 'lc_insts'.  'LinkedComponent's cannot be instantiated+-- (e.g., there is no 'ModSubst' instance for them).+lc_uid :: LinkedComponent -> OpenUnitId+lc_uid lc = IndefFullUnitId (lc_cid lc) . Map.fromList $ lc_insts lc++-- | The instantiation of 'lc_uid'; this always has the invariant+-- that it is a mapping from a module name @A@ to @<A>@ (the hole A).+lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)]+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))++instance Package LinkedComponent where+  packageId = lc_pkgid++toLinkedComponent+  :: Verbosity+  -> Bool+  -- ^ Whether there are any "promised" package dependencies which we won't find already installed.+  -> FullDb+  -> PackageId+  -> LinkedComponentMap+  -> ConfiguredComponent+  -> LogProgress LinkedComponent+toLinkedComponent+  verbosity+  anyPromised+  db+  this_pid+  pkg_map+  ConfiguredComponent+    { cc_ann_id = aid@AnnotatedId{ann_id = this_cid}+    , cc_component = component+    , cc_exe_deps = exe_deps+    , cc_public = is_public+    , cc_includes = cid_includes+    } = do+    let+      -- The explicitly specified requirements, provisions and+      -- reexports from the Cabal file.  These are only non-empty for+      -- libraries; everything else is trivial.+      ( src_reqs :: [ModuleName]+        , src_provs :: [ModuleName]+        , src_reexports :: [ModuleReexport]+        ) =+          case component of+            CLib lib ->+              ( signatures lib+              , exposedModules lib+              , reexportedModules lib+              )+            _ -> ([], [], [])+      src_hidden = otherModules (componentBuildInfo component)++      -- Take each included ComponentId and resolve it into an+      -- \*unlinked* unit identity.  We will use unification (relying+      -- on the ModuleShape) to resolve these into linked identities.+      unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]+      unlinked_includes =+        [ ComponentInclude (fmap lookupUid dep_aid) rns i+        | ComponentInclude dep_aid rns i <- cid_includes+        ]++      lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)+      lookupUid cid =+        fromMaybe+          (error "linkComponent: lookupUid")+          (Map.lookup cid pkg_map)++    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]+                )+            )++    -- 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+          ]+        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+        -- 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)+        -- Handle 'exposed-modules'+        exposed_mod_shapes_u <- traverse (convertMod FromExposedModules) src_provs+        -- Handle 'other-modules'+        other_mod_shapes_u <- traverse (convertMod FromOtherModules) src_hidden++        -- 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_shapes_u <- traverse convertReq src_reqs++        -- Handle 'mixins'+        (incl_shapes_u, all_includes_u) <- fmap unzip (traverse convertInclude unlinked_includes)++        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++        -- src_reqs_u <- traverse convertReq src_reqs+        -- Read out all the final results by converting back+        -- into a pure representation.+        let convertIncludeU (ComponentInclude dep_aid rns i) = do+              let component_name = pretty $ ann_cname dep_aid+              uid <- convertUnitIdU (ann_id dep_aid) component_name+              return+                ( ComponentInclude+                    { ci_ann_id = dep_aid{ann_id = uid}+                    , ci_renaming = rns+                    , ci_implicit = i+                    }+                )++        shape <- convertModuleScopeU shape_u+        let (includes_u, sig_includes_u) = partitionEithers all_includes_u+        incls <- traverse convertIncludeU includes_u+        sig_incls <- traverse convertIncludeU sig_includes_u+        return (shape, incls, sig_incls)++    let isNotLib (CLib _) = False+        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])++    -- 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 =+                -- Would rather use withoutKeys but need BC+                Map.filterWithKey+                  (\k _ -> not (k `Set.member` src_hidden_set))+                  (modScopeProvides linked_shape0)+            }++    -- OK, compute the reexports+    -- TODO: This code reports the errors for reexports one reexport at+    -- a time.  Better to collect them all up and report them all at+    -- 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])+    reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do+      case Map.lookup from (modScopeProvides linked_shape) of+        Just cands@(x0 : xs0) -> do+          -- Make sure there is at least one candidate+          (x, xs) <-+            case mb_pn of+              Just 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)+              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, Just (unWithSource x))+        _ ->+          -- 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!+        -- 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)++    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]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Suppose we have p-indef, which depends on str-sig and inherits+-- the hole from that signature package.  When we instantiate p-indef,+-- it's a bit pointless to also go ahead and build str-sig, because+-- str-sig cannot possibly have contributed any code to the package+-- in question.  Furthermore, because the signature was inherited to+-- p-indef, if we test matching against p-indef, we also have tested+-- matching against p-sig.  In fact, skipping p-sig is *mandatory*,+-- because p-indef may have thinned it (so that an implementation may+-- match p-indef but not p-sig.)+--+-- However, suppose that we have a package which mixes together str-sig+-- and str-bytestring, with the intent of *checking* that str-sig is+-- implemented by str-bytestring.  Here, it's quite important to+-- build an instantiated str-sig, since that is the only way we will+-- actually end up testing if the matching works.  Note that this+-- admonition only applies if the package has NO requirements; if it+-- has any requirements, we will typecheck it as an indefinite+-- package, at which point the signature includes will be passed to+-- GHC who will in turn actually do the checking to make sure they+-- are instantiated correctly.++-- Handle mix-in linking for components.  In the absence of Backpack,+-- every ComponentId gets converted into a UnitId by way of SimpleUnitId.+toLinkedComponents+  :: Verbosity+  -> Bool+  -- ^ Whether there are any "promised" package dependencies which we won't+  -- find already installed.+  -> FullDb+  -> PackageId+  -> LinkedComponentMap+  -> [ConfiguredComponent]+  -> LogProgress [LinkedComponent]+toLinkedComponents verbosity anyPromised db this_pid lc_map0 comps =+  fmap snd (mapAccumM go lc_map0 comps)+  where+    go+      :: Map ComponentId (OpenUnitId, ModuleShape)+      -> ConfiguredComponent+      -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent)+    go lc_map cc = do+      lc <-+        addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $+          toLinkedComponent verbosity anyPromised db this_pid lc_map cc+      return (extendLinkedComponentMap lc lc_map, lc)++type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape)++extendLinkedComponentMap+  :: LinkedComponent+  -> LinkedComponentMap+  -> LinkedComponentMap+extendLinkedComponentMap 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)+    ]+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."+    ]++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+    ]+  where+    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]'."+        ]+    -- 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)+        ]
+ src/Distribution/Backpack/MixLink.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE NondecreasingIndentation #-}++-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.MixLink+  ( mixLink+  ) where++import Distribution.Compat.Prelude hiding (mod)+import Prelude ()++import Distribution.Backpack+import Distribution.Backpack.FullUnitId+import Distribution.Backpack.ModuleScope+import Distribution.Backpack.UnifyM++import Distribution.ModuleName+import Distribution.Pretty+import Distribution.Types.ComponentId+import qualified Distribution.Utils.UnionFind as UnionFind++import Control.Monad+import qualified Data.Foldable as F+import qualified Data.Map as Map+import Text.PrettyPrint++-----------------------------------------------------------------------+-- Linking++-- | 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)++-- | 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+  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)+    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]+          )+linkProvision _ _ _ = error "linkProvision"++-----------------------------------------------------------------------+-- The unification algorithm++-- This is based off of https://gist.github.com/amnn/559551517d020dbb6588+-- which is a translation from Huet's thesis.++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++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++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++-- | 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
+ src/Distribution/Backpack/ModSubst.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternGuards #-}++-- | A type class 'ModSubst' for objects which can have 'ModuleSubst'+-- applied to them.+--+-- See also <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.ModSubst+  ( ModSubst (..)+  ) where++import Distribution.Compat.Prelude hiding (mod)+import Prelude ()++import Distribution.Backpack+import Distribution.ModuleName++import qualified Data.Map as Map+import qualified Data.Set as Set++-- | Applying module substitutions to semantic objects.+class ModSubst a where+  -- In notation, substitution is postfix, which implies+  -- putting it on the right hand side, but for partial+  -- application it's more convenient to have it on the left+  -- hand side.+  modSubst :: OpenModuleSubst -> a -> a++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++instance ModSubst OpenUnitId where+  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)++-- 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)+instance ModSubst a => ModSubst [a] where+  modSubst subst = fmap (modSubst subst)+instance ModSubst a => ModSubst (k, a) where+  modSubst subst (x, y) = (x, modSubst subst y)
+ src/Distribution/Backpack/ModuleScope.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE DeriveTraversable #-}++-- | 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++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.ModuleName+import Distribution.Pretty+import Distribution.Types.ComponentName+import Distribution.Types.IncludeRenaming+import Distribution.Types.LibraryName+import Distribution.Types.PackageName++import Distribution.Backpack+import Distribution.Backpack.ModSubst++import qualified Data.Map as Map+import Text.PrettyPrint++-----------------------------------------------------------------------+-- Module scopes++-- Why is ModuleProvides so complicated?  The basic problem is that+-- we want to support this:+--+--  package p where+--      include q (A)+--      include r (A)+--      module B where+--          import "q" A+--          import "r" A+--+-- Specifically, in Cabal today it is NOT an error have two modules in+-- scope with the same identifier.  So we need to preserve this for+-- Backpack.  The modification is that an ambiguous module name is+-- OK... as long as it is NOT used to fill a requirement!+--+-- So as a first try, we might try deferring unifying provisions that+-- are being glommed together, and check for equality after the fact.+-- But this doesn't work, because what if a multi-module provision+-- is used to fill a requirement?!  So you do the equality test+-- IMMEDIATELY before a requirement fill happens... or never at all.+--+-- 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+  }++-- | An empty 'ModuleScope'.+emptyModuleScope :: ModuleScope+emptyModuleScope = ModuleScope Map.empty Map.empty++-- | Every 'Module' in scope at a 'ModuleName' is annotated with+-- the 'PackageName' it comes from.+type ModuleProvides = Map ModuleName [ModuleWithSource]++-- | INVARIANT: entries for ModuleName m, have msrc_module is OpenModuleVar m+type ModuleRequires = Map ModuleName [ModuleWithSource]++-- TODO: consider newtping the two types above.++-- | Description of where a module participating in mixin linking came+-- from.+data ModuleSource+  = FromMixins PackageName ComponentName IncludeRenaming+  | FromBuildDepends PackageName ComponentName+  | FromExposedModules ModuleName+  | FromOtherModules ModuleName+  | FromSignatures ModuleName++-- 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++-- 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)++-- | An 'OpenModule', annotated with where it came from in a Cabal file.+data WithSource a = WithSource ModuleSource a+  deriving (Functor, Foldable, Traversable)++unWithSource :: WithSource a -> a+unWithSource (WithSource _ x) = x+getSource :: WithSource a -> ModuleSource+getSource (WithSource s _) = s+type ModuleWithSource = WithSource OpenModule++instance ModSubst a => ModSubst (WithSource a) where+  modSubst subst (WithSource s m) = WithSource s (modSubst subst m)
+ src/Distribution/Backpack/ModuleShape.hs view
@@ -0,0 +1,84 @@+{-# 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++import Distribution.Compat.Prelude hiding (mod)+import Prelude ()++import Distribution.InstalledPackageInfo as IPI+import Distribution.ModuleName++import Distribution.Backpack+import Distribution.Backpack.ModSubst++import qualified Data.Map as Map+import qualified Data.Set as Set++-----------------------------------------------------------------------+-- Module shapes++-- | 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)++instance Binary ModuleShape+instance Structured ModuleShape++instance ModSubst ModuleShape where+  modSubst subst (ModuleShape provs reqs) =+    ModuleShape (modSubst subst provs) (modSubst subst reqs)++-- | The default module shape, with no provisions and no requirements.+emptyModuleShape :: ModuleShape+emptyModuleShape = ModuleShape Map.empty Set.empty++-- Food for thought: suppose we apply the Merkel tree optimization.+-- Imagine this situation:+--+--      component p+--          signature H+--          module P+--      component h+--          module H+--      component a+--          signature P+--          module A+--      component q(P)+--          include p+--          include h+--      component r+--          include q (P)+--          include p (P) requires (H)+--          include h (H)+--          include a (A) requires (P)+--+-- Component r should not have any conflicts, since after mix-in linking+-- the two P imports will end up being the same, so we can properly+-- instantiate it.  But to know that q's P is p:P instantiated with h:H,+-- we have to be able to expand its unit id.  Maybe we can expand it+-- lazily but in some cases it will need to be expanded.+--+-- FWIW, the way that GHC handles this is by improving unit IDs as+-- soon as it sees an improved one in the package database.  This+-- is a bit disgusting.+shapeInstalledPackage :: IPI.InstalledPackageInfo -> ModuleShape+shapeInstalledPackage ipi = ModuleShape (Map.fromList provs) reqs+  where+    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)
+ src/Distribution/Backpack/PreExistingComponent.hs view
@@ -0,0 +1,79 @@+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.PreExistingComponent+  ( PreExistingComponent (..)+  , ConfiguredPromisedComponent (..)+  , ipiToPreExistingComponent+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Backpack+import Distribution.Backpack.ModuleShape+import Distribution.Package+import Distribution.Types.ComponentName+import Distribution.Types.MungedPackageId++import qualified Data.Map as Map+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+  { 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+    }++instance HasMungedPackageId PreExistingComponent where+  mungedId = pc_munged_id++instance Package PreExistingComponent where+  packageId pec = PackageIdentifier (pc_pkgname pec) v+    where+      MungedPackageId _ v = pc_munged_id pec++instance HasUnitId PreExistingComponent where+  installedUnitId = pc_uid
+ src/Distribution/Backpack/PreModuleShape.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Backpack.PreModuleShape+  ( PreModuleShape (..)+  , toPreModuleShape+  , renamePreModuleShape+  , mixLinkPreModuleShape+  ) where++import Distribution.Compat.Prelude+import Prelude ()++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++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)+  where+    prov_fn = interpModuleRenaming prov_rn+    req_fn k = fromMaybe k (interpModuleRenaming req_rn k)++mixLinkPreModuleShape :: [PreModuleShape] -> PreModuleShape+mixLinkPreModuleShape shapes = PreModuleShape provs (Set.difference reqs provs)+  where+    provs = Set.unions (map preModShapeProvides shapes)+    reqs = Set.unions (map preModShapeRequires shapes)
+ src/Distribution/Backpack/ReadyComponent.hs view
@@ -0,0 +1,412 @@+{-# 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++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.Component+import Distribution.Types.ComponentId+import Distribution.Types.ComponentInclude+import Distribution.Types.ComponentName+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.PackageId+import Distribution.Types.PackageName.Magic+import Distribution.Types.UnitId++import Distribution.ModuleName+import Distribution.Package+import Distribution.Simple.Utils++import Control.Monad+import qualified Data.Map as Map+import qualified Data.Set as Set+import Text.PrettyPrint++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+  , 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 = ann_id . rc_ann_id++-- | Corresponds to 'lc_pkgid'.+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+  { 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+  { 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+  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)+        )++-- | 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"+    )++instance Package ReadyComponent where+  packageId = rc_pkgid++instance HasUnitId ReadyComponent where+  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)++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+      ]++-- | The state of 'InstM'; a mapping from 'UnitId's to their+-- ready component, or @Nothing@ if its an external+-- component which we don't know how to build.+type InstS = Map UnitId (Maybe ReadyComponent)++-- | A state monad for doing instantiations (can't use actual+-- State because that would be an extra dependency.)+newtype InstM a = InstM {runInstM :: InstS -> (a, InstS)}++instance Functor InstM where+  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'')++instance Monad InstM where+  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+-- instantiated components we need to build.+--+-- Instantiation intuitively follows the following algorithm:+--+--      instantiate a definite unit id p[S]:+--          recursively instantiate each module M in S+--          recursively instantiate modules exported by this unit+--          recursively instantiate dependencies substituted by S+--+-- The implementation is a bit more involved to memoize instantiation+-- if we have done it already.+--+-- 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)+  where+    cmap = Map.fromList [(lc_cid lc, lc) | lc <- comps]++    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)+      where+        -- The mkDefUnitId here indicates that we assume+        -- that Cabal handles unit id hash allocation.+        -- Good thing about hashing here: map is only on string.+        -- Bad thing: have to repeatedly hash.+        def_uid = mkDefUnitId cid insts+        uid = unDefUnitId def_uid++    instantiateComponent+      :: 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 =+                    -- 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+                }+      | otherwise = return Nothing++    substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId+    substUnitId _ (DefiniteUnitId uid) =+      return uid+    substUnitId subst (IndefFullUnitId cid insts) = do+      insts' <- substSubst subst insts+      instantiateUnitId cid insts'++    -- NB: NOT composition+    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"+    substModule subst (OpenModule uid mod_name) = do+      uid' <- substUnitId subst uid+      return (Module uid' mod_name)++    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'}++    indefiniteUnitId :: ComponentId -> InstM UnitId+    indefiniteUnitId cid = do+      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+                }+      | 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 ->+            if null (lc_insts lc)+              then instantiateUnitId (lc_cid lc) Map.empty >> return ()+              else indefiniteUnitId (lc_cid lc) >> return ()
+ src/Distribution/Backpack/UnifyM.hs view
@@ -0,0 +1,676 @@+{-# 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++    -- * Modules and unit IDs+  , ModuleU+  , ModuleU' (..)+  , convertModule+  , convertModuleU+  , UnitIdU+  , UnitIdU' (..)+  , convertUnitId+  , convertUnitIdU+  , ModuleSubstU+  , convertModuleSubstU+  , convertModuleSubst+  , ModuleScopeU+  , emptyModuleScopeU+  , convertModuleScopeU+  , ModuleWithSourceU+  , convertInclude+  , convertModuleProvides+  , convertModuleProvidesU+  ) where++import Distribution.Compat.Prelude hiding (mod)+import Prelude ()++import Distribution.Backpack+import Distribution.Backpack.FullUnitId+import Distribution.Backpack.ModSubst+import Distribution.Backpack.ModuleScope+import Distribution.Backpack.ModuleShape++import Distribution.ModuleName+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Pretty+import Distribution.Types.AnnotatedId+import Distribution.Types.ComponentInclude+import qualified Distribution.Utils.UnionFind as UnionFind+import Distribution.Verbosity++import Control.Monad.ST+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]+  }+type MsgDoc = Doc++renderErrMsg :: ErrMsg -> MsgDoc+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)}++-- | 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)))++-- 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+  { 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)++instance Applicative (UnifyM s) where+  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 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++-- | Lift a computation from 'ST' monad to 'UnifyM' monad.+-- Internal use only.+liftST :: ST s a -> UnifyM s a+liftST m = UnifyM $ \_ -> fmap Just m++addErr :: MsgDoc -> UnifyM s ()+addErr msg = do+  env <- getUnifEnv+  let err =+        ErrMsg+          { err_msg = msg+          , err_ctx = unify_ctx env+          }+  liftST $ modifySTRef (unify_errs env) (\errs -> err : errs)++failWith :: MsgDoc -> UnifyM s a+failWith msg = do+  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++tryM :: UnifyM s a -> UnifyM s (Maybe a)+tryM m =+  UnifyM+    ( \env -> do+        mb_r <- unUnifyM m env+        return (Just mb_r)+    )++{-+otherFail :: ErrMsg -> UnifyM s a+otherFail s = UnifyM $ \_ -> return (Left s)++unifyFail :: ErrMsg -> UnifyM s a+unifyFail err = do+    env <- getUnifEnv+    msg <- case unify_ctx env of+        Nothing -> return (text "Unspecified unification error:" <+> err)+        Just (ctx, mod1, mod2)+            | unify_verbosity env > normal+            -> do mod1' <- convertModuleU mod1+                  mod2' <- convertModuleU mod2+                  let extra = " (was unifying " ++ display mod1'+                                     ++ " and " ++ display mod2' ++ ")"+                  return (ctx ++ err ++ extra)+            | otherwise+            -> return (ctx ++ err ++ " (for more information, pass -v flag)")+    UnifyM $ \_ -> return (Left msg)+-}++-- | A convenient alias for mutable references in the unification monad.+type UnifRef s a = STRef s a++-- | Imperatively read a 'UnifRef'.+readUnifRef :: UnifRef s a -> UnifyM s a+readUnifRef = liftST . readSTRef++-- | Imperatively write a 'UnifRef'.+writeUnifRef :: UnifRef s a -> a -> UnifyM s ()+writeUnifRef x = liftST . writeSTRef x++-- | Get the current unification environment.+getUnifEnv :: UnifyM s (UnifEnv s)+getUnifEnv = UnifyM $ \r -> return (return r)++-- | Add a fixed message to the error context.+addErrContext :: Doc -> UnifyM s a -> UnifyM s a+addErrContext ctx m = addErrContextM ctx m++-- | Add a message to the error context.  It may make monadic queries.+addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a+addErrContextM ctx m =+  UnifyM $ \r -> unUnifyM m r{unify_ctx = ctx : unify_ctx r}++-----------------------------------------------------------------------+-- The "unifiable" variants of the data types+--+-- In order to properly do unification over infinite trees, we+-- need to union find over 'Module's and 'UnitId's.  The pure+-- representation is ill-equipped to do this, so we convert+-- from the pure representation into one which is indirected+-- through union-find.  'ModuleU' handles hole variables;+-- 'UnitIdU' handles mu-binders.++-- | Contents of a mutable 'ModuleU' reference.+data ModuleU' s+  = ModuleU (UnitIdU s) ModuleName+  | ModuleVarU ModuleName++-- | Contents of a mutable 'UnitIdU' reference.+data UnitIdU' s+  = 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)++-- | A mutable version of 'UnitId' which can be imperatively unified.+type UnitIdU s = UnionFind.Point s (UnitIdU' s)++-- | An integer for uniquely labeling 'UnitIdU' nodes.  We need+-- these labels in order to efficiently serialize 'UnitIdU's into+-- 'UnitId's (we use the label to check if any parent is the+-- node in question, and if so insert a deBruijn index instead.)+-- These labels must be unique across all 'UnitId's/'Module's which+-- participate in unification!+type UnitIdUnique = Int++-----------------------------------------------------------------------+-- Conversion to the unifiable data types++-- An environment for tracking the mu-bindings in scope.+-- The invariant for a state @(m, i)@ is that [0..i] are+-- keys of @m@; in fact, the @i-k@th entry is the @k@th+-- de Bruijn index (this saves us from having to shift as+-- we enter mu-binders.)+type MuEnv s = (IntMap (UnitIdU s), Int)++extendMuEnv :: MuEnv s -> UnitIdU s -> MuEnv s+extendMuEnv (m, i) x =+  (IntMap.insert (i + 1) x m, i + 1)++{-+lookupMuEnv :: MuEnv s -> Int {- de Bruijn index -} -> UnitIdU s+lookupMuEnv (m, i) k =+    case IntMap.lookup (i - k) m of+        -- Technically a user can trigger this by giving us a+        -- bad 'UnitId', so handle this better.+        Nothing -> error "lookupMuEnv: out of bounds (malformed de Bruijn index)"+        Just v -> v+-}++emptyMuEnv :: MuEnv s+emptyMuEnv = (IntMap.empty, -1)++-- The workhorse functions.  These share an environment:+--   * @UnifRef s UnitIdUnique@ - the unique label supply for 'UnitIdU' nodes+--   * @UnifRef s (Map ModuleName moduleU)@ - the (lazily initialized)+--     environment containing the implicitly universally quantified+--     @hole:A@ binders.+--   * @MuEnv@ - the environment for mu-binders.++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)+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++-- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i)++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+convertModule' stk (OpenModule uid mod_name) = do+  uid_u <- convertUnitId' stk uid+  liftST $ UnionFind.fresh (ModuleU uid_u mod_name)++convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s)+convertUnitId = convertUnitId' emptyMuEnv++convertModule :: OpenModule -> UnifyM s (ModuleU s)+convertModule = convertModule' emptyMuEnv++-----------------------------------------------------------------------+-- Substitutions++-- | The mutable counterpart of a 'ModuleSubst' (not defined here).+type ModuleSubstU s = Map ModuleName (ModuleU s)++-- | Conversion of 'ModuleSubst' to 'ModuleSubstU'+convertModuleSubst :: Map ModuleName OpenModule -> UnifyM s (Map ModuleName (ModuleU s))+convertModuleSubst = traverse convertModule++-- | Conversion of 'ModuleSubstU' to 'ModuleSubst'+convertModuleSubstU :: ModuleSubstU s -> UnifyM s OpenModuleSubst+convertModuleSubstU = traverse convertModuleU++-----------------------------------------------------------------------+-- Conversion from the unifiable data types++-- An environment for tracking candidates for adding a mu-binding.+-- The invariant for a state @(m, i)@, is that if we encounter a node+-- labeled @k@ such that @m[k -> v]@, then we can replace this+-- node with the de Bruijn index @i-v@ referring to an enclosing+-- mu-binder; furthermore, @range(m) = [0..i]@.+type MooEnv = (IntMap Int, Int)++emptyMooEnv :: MooEnv+emptyMooEnv = (IntMap.empty, -1)++extendMooEnv :: MooEnv -> UnitIdUnique -> MooEnv+extendMooEnv (m, i) k = (IntMap.insert k (i + 1) m, i + 1)++lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int+lookupMooEnv (m, i) k =+  case IntMap.lookup k m of+    Nothing -> Nothing+    Just v -> Just (i - v) -- de Bruijn indexize++-- The workhorse functions++-- | 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 (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 -> Doc -> UnifyM s OpenUnitId+convertUnitIdU = convertUnitIdU' emptyMooEnv++convertModuleU :: ModuleU s -> UnifyM s OpenModule+convertModuleU = convertModuleU' emptyMooEnv++-- | An empty 'ModuleScopeU'.+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)++-- TODO: Deduplicate this with Distribution.Backpack.MixLink.dispSource+ci_msg :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming -> Doc+ci_msg ci+  | ci_implicit ci = text "build-depends:" <+> pp_pn+  | otherwise = text "mixins:" <+> pp_pn <+> pretty (ci_renaming ci)+  where+    pn = pkgName (ci_pkgid ci)+    pp_pn =+      case ci_cname ci of+        CLibName LMainLibName -> pretty pn+        CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn+        -- Shouldn't happen+        cn -> pretty pn <+> parens (pretty cn)++-- | 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+    let pn = packageName pid+        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+    -- we include it with @requires (A as X)@+    -- There are three closely related things we compute based+    -- off of @reqs@ and @reqs_rns@:+    --+    --      1. The requirement renaming (A -> X)+    --      2. The requirement substitution (A -> <X>, B -> <B>)++    -- Requirement renaming.  This is read straight off the syntax:+    --+    --      [nothing]          ==>  [empty]+    --      requires (B as Y)  ==>  B -> Y+    --+    -- Requirement renamings are NOT injective: if two requirements+    -- are mapped to the same name, the intent is to merge them+    -- together.  But they are *functions*, so @B as X, B as Y@ is+    -- illegal.++    req_rename_list <-+      case req_rns of+        DefaultRenaming -> return []+        HidingRenaming _ -> do+          -- 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]+    req_rename <- sequenceA . flip Map.mapWithKey req_rename_listmap $ \k vs0 ->+      case vs0 of+        [] -> 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++    let req_rename_fn k = case Map.lookup k req_rename of+          Nothing -> k+          Just v -> v++    -- Requirement substitution.+    --+    --      A -> X      ==>     A -> <X>+    let req_subst = fmap OpenModuleVar req_rename++    uid_u <- convertUnitId (modSubst req_subst uid)++    -- Requirement mapping.  This is just taking the range of the+    -- requirement substitution, and making a mapping so that it is+    -- convenient to merge things together.  It INCLUDES the implicit+    -- mappings.+    --+    --      A -> X      ==>     X -> <X>, B -> <B>+    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)))++    -- Provision computation is more complex.+    -- For example, if we have:+    --+    --      include p (A as X) requires (B as Y)+    --          where A -> q[B=<B>]:A+    --+    -- Then we need:+    --+    --      X -> [("p", q[B=<B>]:A)]+    --+    -- There are a bunch of clever ways to present the algorithm+    -- but here is the simple one:+    --+    --      1. If we have a default renaming, apply req_subst+    --      to provs and use that.+    --+    --      2. Otherwise, build a map by successively looking+    --      up the referenced modules in the renaming in provs.+    --+    -- 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)+                    ]+               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+              }+          )+      )++-- | 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)++-- | Convert a 'ModuleProvides' to a 'ModuleProvidesU'+convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s)+convertModuleProvides = traverse (traverse (traverse convertModule))++-- | Convert a 'ModuleProvidesU' to a 'ModuleProvides'+convertModuleProvidesU :: ModuleProvidesU s -> UnifyM s ModuleProvides+convertModuleProvidesU = traverse (traverse (traverse convertModuleU))++convertModuleRequires :: ModuleRequires -> UnifyM s (ModuleRequiresU s)+convertModuleRequires = convertModuleProvides++convertModuleRequiresU :: ModuleRequiresU s -> UnifyM s ModuleRequires+convertModuleRequiresU = convertModuleProvidesU
+ src/Distribution/Compat/Async.hs view
@@ -0,0 +1,155 @@+-- | 'Async', yet using 'MVar's.+--+-- Adopted from @async@ library+-- Copyright (c) 2012, Simon Marlow+-- Licensed under BSD-3-Clause+--+-- @since 3.2.0.0+module Distribution.Compat.Async+  ( AsyncM+  , withAsync+  , waitCatch+  , wait+  , asyncThreadId+  , cancel+  , uninterruptibleCancel+  , AsyncCancelled (..)++    -- * Cabal extras+  , withAsyncNF+  ) where++import Control.Concurrent (ThreadId, forkIO)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)+import Control.DeepSeq (NFData, force)+import Control.Exception+  ( 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)+  }++-- | Spawn an asynchronous action in a separate thread, and pass its+-- @Async@ handle to the supplied function.  When the function returns+-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@.+--+-- > withAsync action inner = mask $ \restore -> do+-- >   a <- async (restore action)+-- >   restore (inner a) `finally` uninterruptibleCancel a+--+-- This is a useful variant of 'async' that ensures an @Async@ is+-- never left running unintentionally.+--+-- 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+    evaluateNF = evaluate . force++withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b+-- The bracket version works, but is slow.  We can do better by+-- hand-coding it:+withAsyncUsing doFork = \action inner -> do+  var <- newEmptyMVar+  mask $ \restore -> do+    t <- doFork $ try (restore action) >>= putMVar var+    let a = Async t var+    r <-+      restore (inner a) `catchAll` \e -> do+        uninterruptibleCancel a+        throwIO e+    uninterruptibleCancel a+    return r++-- | Wait for an asynchronous action to complete, and return its+-- value.  If the asynchronous action threw an exception, then the+-- 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++-- | 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)+  where+    -- See: https://github.com/simonmar/async/issues/14+    tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f++catchAll :: IO a -> (SomeException -> IO a) -> IO a+catchAll = catch++-- | Cancel an asynchronous action by throwing the @AsyncCancelled@+-- exception to it, and waiting for the `Async` thread to quit.+-- Has no effect if the 'Async' has already completed.+--+-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a+--+-- Note that 'cancel' will not terminate until the thread the 'Async'+-- refers to has terminated. This means that 'cancel' will block for+-- as long said thread blocks when receiving an asynchronous exception.+--+-- For example, it could block if:+--+-- * It's executing a foreign call, and thus cannot receive the asynchronous+-- exception;+-- * It's executing some cleanup handler after having received the exception,+-- and the handler is blocking.+{-# INLINE cancel #-}+cancel :: AsyncM a -> IO ()+cancel a@(Async t _) = do+  throwTo t AsyncCancelled+  void (waitCatch a)++-- | The exception thrown by `cancel` to terminate a thread.+data AsyncCancelled = AsyncCancelled+  deriving+    ( Show+    , Eq+    )++instance Exception AsyncCancelled where+  -- wraps in SomeAsyncException+  -- See https://github.com/ghc/ghc/commit/756a970eacbb6a19230ee3ba57e24999e4157b09+  fromException = asyncExceptionFromException+  toException = asyncExceptionToException++-- | Cancel an asynchronous action+--+-- This is a variant of `cancel`, but it is not interruptible.+{-# INLINE uninterruptibleCancel #-}+uninterruptibleCancel :: AsyncM a -> IO ()+uninterruptibleCancel = uninterruptibleMask_ . cancel
+ src/Distribution/Compat/CopyFile.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}++module Distribution.Compat.CopyFile+  ( copyFile+  , copyFileChanged+  , filesEqual+  , copyOrdinaryFile+  , copyExecutableFile+  , setFileOrdinary+  , setFileExecutable+  , setDirOrdinary+  ) where++import Distribution.Compat.Prelude+import Prelude ()++#ifndef mingw32_HOST_OS+import Distribution.Compat.Internal.TempFile++import Control.Exception+         ( bracketOnError )+import qualified Data.ByteString.Lazy as BSL+import Data.Bits+         ( (.|.) )+import System.IO.Error+         ( ioeSetLocation )+import System.Directory+         ( doesFileExist, renameFile, removeFile )+import System.FilePath+         ( takeDirectory )+import System.IO+         ( IOMode(ReadMode), hClose, hGetBuf, hPutBuf, hFileSize+         , withBinaryFile )+import Foreign+         ( allocaBytes )++import System.Posix.Types+         ( FileMode )+import System.Posix.Files+         ( getFileStatus, fileMode, setFileMode )++#else /* else mingw32_HOST_OS */++import qualified Data.ByteString.Lazy as BSL+import System.IO.Error+  ( ioeSetLocation )+import System.Directory+  ( doesFileExist )+import System.FilePath+  ( addTrailingPathSeparator+  , hasTrailingPathSeparator+  , isPathSeparator+  , isRelative+  , joinDrive+  , joinPath+  , pathSeparator+  , pathSeparators+  , splitDirectories+  , splitDrive+  )+import System.IO+  ( IOMode(ReadMode), hFileSize+  , withBinaryFile )++import qualified System.Win32.File as Win32 ( copyFile )+#endif /* mingw32_HOST_OS */++copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()+copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest+copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest++setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO ()+#ifndef mingw32_HOST_OS+-- 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++addFileMode :: FilePath -> FileMode -> IO ()+addFileMode name m = do+  o <- fileMode <$> getFileStatus name+  setFileMode name (m .|. o)+#else+setFileOrdinary   _ = return ()+setFileExecutable _ = return ()+#endif+-- This happens to be true on Unix and currently on Windows too:+setDirOrdinary = setFileExecutable++-- | Copies a file to a new destination.+-- Often you should use `copyFileChanged` instead.+copyFile :: FilePath -> FilePath -> IO ()+copyFile fromFPath toFPath =+  copy+    `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile"))+  where+#ifndef mingw32_HOST_OS+      copy = withBinaryFile fromFPath ReadMode $ \hFrom ->+             bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->+             do allocaBytes bufferSize $ copyContents hFrom hTmp+                hClose hTmp+                renameFile tmpFPath toFPath+      openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"+      cleanTmp (tmpFPath, hTmp) = do+        hClose hTmp          `catchIO` \_ -> return ()+        removeFile tmpFPath  `catchIO` \_ -> return ()+      bufferSize = 4096++      copyContents hFrom hTo buffer = do+              count <- hGetBuf hFrom buffer bufferSize+              when (count > 0) $ do+                      hPutBuf hTo buffer count+                      copyContents hFrom hTo buffer+#else+      copy = Win32.copyFile (toExtendedLengthPath fromFPath)+                            (toExtendedLengthPath toFPath)+                            False++-- NOTE: Shamelessly lifted from System.Directory.Internal.Windows++-- | Add the @"\\\\?\\"@ prefix if necessary or possible.  The path remains+-- unchanged if the prefix is not added.  This function can sometimes be used+-- to bypass the @MAX_PATH@ length restriction in Windows API calls.+--+-- See Note [Path normalization].+toExtendedLengthPath :: FilePath -> FilePath+toExtendedLengthPath path+  | isRelative path = path+  | otherwise =+      case normalisedPath of+        '\\' : '?'  : '?' : '\\' : _ -> normalisedPath+        '\\' : '\\' : '?' : '\\' : _ -> normalisedPath+        '\\' : '\\' : '.' : '\\' : _ -> normalisedPath+        '\\' : subpath@('\\' : _)    -> "\\\\?\\UNC" <> subpath+        _                            -> "\\\\?\\" <> normalisedPath+    where normalisedPath = simplifyWindows path++-- | Similar to 'normalise' but:+--+-- * empty paths stay empty,+-- * parent dirs (@..@) are expanded, and+-- * paths starting with @\\\\?\\@ are preserved.+--+-- The goal is to preserve the meaning of paths better than 'normalise'.+--+-- Note [Path normalization]+-- 'normalise' doesn't simplify path names but will convert / into \\+-- this would normally not be a problem as once the path hits the RTS we would+-- have simplified the path then.  However since we're calling the WIn32 API+-- directly we have to do the simplification before the call.  Without this the+-- path Z:// would become Z:\\\\ and when converted to a device path the path+-- becomes \\?\Z:\\\\ which is an invalid path.+--+-- This is not a bug in normalise as it explicitly states that it won't simplify+-- a FilePath.+simplifyWindows :: FilePath -> FilePath+simplifyWindows "" = ""+simplifyWindows path =+  case drive' of+    "\\\\?\\" -> drive' <> subpath+    _ -> simplifiedPath+  where+    simplifiedPath = joinDrive drive' subpath'+    (drive, subpath) = splitDrive path+    drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive))+    subpath' = appendSep . avoidEmpty . prependSep . joinPath .+               stripPardirs . expandDots . skipSeps .+               splitDirectories $ subpath++    upperDrive d = case d of+      c : ':' : s | isAlpha c && all isPathSeparator s -> toUpper c : ':' : s+      _ -> d+    skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))+    stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..")+                 | otherwise = id+    prependSep | subpathIsAbsolute = (pathSeparator :)+               | otherwise = id+    avoidEmpty | not pathIsAbsolute+                 && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:."+                 = emptyToCurDir+               | otherwise = id+    appendSep p | hasTrailingPathSep+                  && not (pathIsAbsolute && null p)+                  = addTrailingPathSeparator p+                | otherwise = p+    pathIsAbsolute = not (isRelative path)+    subpathIsAbsolute = any isPathSeparator (take 1 subpath)+    hasTrailingPathSep = hasTrailingPathSeparator subpath++-- | Given a list of path segments, expand @.@ and @..@.  The path segments+-- must not contain path separators.+expandDots :: [FilePath] -> [FilePath]+expandDots = reverse . go []+  where+    go ys' xs' =+      case xs' of+        [] -> ys'+        x : xs ->+          case x of+            "." -> go ys' xs+            ".." ->+              case ys' of+                [] -> go (x : ys') xs+                ".." : _ -> go (x : ys') xs+                _ : ys -> go ys xs+            _ -> go (x : ys') xs++-- | Convert to the right kind of slashes.+normalisePathSeps :: FilePath -> FilePath+normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p++-- | Remove redundant trailing slashes and pick the right kind of slash.+normaliseTrailingSep :: FilePath -> FilePath+normaliseTrailingSep path = do+  let path' = reverse path+  let (sep, path'') = span isPathSeparator path'+  let addSep = if null sep then id else (pathSeparator :)+  reverse (addSep path'')++-- | Convert empty paths to the current directory, otherwise leave it+-- unchanged.+emptyToCurDir :: FilePath -> FilePath+emptyToCurDir ""   = "."+emptyToCurDir path = path+#endif /* mingw32_HOST_OS */++-- | Like `copyFile`, but does not touch the target if source and destination+-- are already byte-identical. This is recommended as it is useful for+-- time-stamp based recompilation avoidance.+copyFileChanged :: FilePath -> FilePath -> IO ()+copyFileChanged src dest = do+  equal <- filesEqual src dest+  unless equal $ copyFile src dest++-- | Checks if two files are byte-identical.+-- Returns False if either of the files do not exist or if files+-- are of different size.+filesEqual :: FilePath -> FilePath -> IO Bool+filesEqual f1 f2 = do+  ex1 <- doesFileExist f1+  ex2 <- doesFileExist f2+  if not (ex1 && ex2)+    then return False+    else withBinaryFile f1 ReadMode $ \h1 ->+      withBinaryFile f2 ReadMode $ \h2 -> do+        s1 <- hFileSize h1+        s2 <- hFileSize h2+        if s1 /= s2+          then return False+          else do+            c1 <- BSL.hGetContents h1+            c2 <- BSL.hGetContents h2+            return $! c1 == c2
+ src/Distribution/Compat/CreatePipe.hs view
@@ -0,0 +1,5 @@+module Distribution.Compat.CreatePipe+  {-# DEPRECATED "Use System.Process from package process directly" #-}+  (createPipe) where++import System.Process (createPipe)
+ src/Distribution/Compat/Directory.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}++module Distribution.Compat.Directory+  ( listDirectory+  , makeAbsolute+  , doesPathExist+  ) where++#if MIN_VERSION_directory(1,2,7)+import System.Directory as Dir hiding (doesPathExist)+import System.Directory (doesPathExist)+#else+import System.Directory as Dir+#endif+#if !MIN_VERSION_directory(1,2,2)+import System.FilePath as Path+#endif++#if !MIN_VERSION_directory(1,2,5)++listDirectory :: FilePath -> IO [FilePath]+listDirectory path =+  filter f `fmap` Dir.getDirectoryContents path+  where f filename = filename /= "." && filename /= ".."++#endif++#if !MIN_VERSION_directory(1,2,2)++makeAbsolute :: FilePath -> IO FilePath+makeAbsolute p | Path.isAbsolute p = return p+               | otherwise         = do+    cwd <- Dir.getCurrentDirectory+    return $ cwd </> p++#endif++#if !MIN_VERSION_directory(1,2,7)++doesPathExist :: FilePath -> IO Bool+doesPathExist path = do+    -- not using Applicative, as this way we can do less IO+    e <- doesDirectoryExist path+    if e+    then return True+    else doesFileExist path++#endif
+ src/Distribution/Compat/Environment.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_HADDOCK hide #-}++module Distribution.Compat.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv)+where++import Distribution.Compat.Prelude+import Prelude ()+import qualified Prelude++import System.Environment (lookupEnv, unsetEnv)+import qualified System.Environment as System++import Distribution.Compat.Stack++#ifdef mingw32_HOST_OS+import Foreign.C+import GHC.Windows+#else+import Foreign.C.Types+import Foreign.C.String+import Foreign.C.Error (throwErrnoIfMinus1_)+import System.Posix.Internals ( withFilePath )+#endif /* mingw32_HOST_OS */++getEnvironment :: IO [(String, String)]+#ifdef mingw32_HOST_OS+-- On Windows, the names of environment variables are case-insensitive, but are+-- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise+-- them.+getEnvironment = fmap upcaseVars System.getEnvironment+  where+    upcaseVars = map upcaseVar+    upcaseVar (var, val) = (map toUpper var, val)+#else+getEnvironment = System.getEnvironment+#endif++-- | @setEnv name value@ sets the specified environment variable to @value@.+--+-- Throws `Control.Exception.IOException` if either @name@ or @value@ is the+-- empty string or contains an equals sign.+setEnv :: String -> String -> IO ()+setEnv key value_ = setEnv_ key value+  where+    -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We+    -- still strip it manually so that the null check above succeeds if a value+    -- starts with NUL.+    value = takeWhile (/= '\NUL') value_++setEnv_ :: String -> String -> IO ()++#ifdef mingw32_HOST_OS++setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do+  success <- c_SetEnvironmentVariable k v+  unless success (throwGetLastError "setEnv")+ where+  _ = callStack -- TODO: attach CallStack to exception++{- FOURMOLU_DISABLE -}+# if defined(i386_HOST_ARCH)+#  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH)+#  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif /* i386_HOST_ARCH */++foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"+  c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> Prelude.IO Bool+#else+setEnv_ key value = do+  withFilePath key $ \ keyP ->+    withFilePath value $ \ valueP ->+      throwErrnoIfMinus1_ "setenv" $+        c_setenv keyP valueP (fromIntegral (fromEnum True))+ where+  _ = callStack -- TODO: attach CallStack to exception++foreign import ccall unsafe "setenv"+   c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt+#endif /* mingw32_HOST_OS */+{- FOURMOLU_ENABLE -}
+ src/Distribution/Compat/FilePath.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}++module Distribution.Compat.FilePath+  ( isExtensionOf+  , stripExtension+  ) where++import Data.List (isSuffixOf, stripPrefix)+import System.FilePath++#if !MIN_VERSION_filepath(1,4,2)+isExtensionOf :: String -> FilePath -> Bool+isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions+isExtensionOf ext         = isSuffixOf ('.':ext) . takeExtensions+#endif++#if !MIN_VERSION_filepath(1,4,1)+stripExtension :: String -> FilePath -> Maybe FilePath+stripExtension []        path = Just path+stripExtension ext@(x:_) path = stripSuffix dotExt path+ where+  dotExt = if isExtSeparator x then ext else '.':ext+  stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+  stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys)+#endif
+ src/Distribution/Compat/GetShortPathName.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Compat.GetShortPathName+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  Windows-only+--+-- Win32 API 'GetShortPathName' function.+module Distribution.Compat.GetShortPathName (getShortPathName)+where++import Distribution.Compat.Prelude+import Prelude ()++#ifdef mingw32_HOST_OS++import qualified Prelude+import qualified System.Win32 as Win32+import System.Win32          (LPCTSTR, LPTSTR, DWORD)+import Foreign.Marshal.Array (allocaArray)++{- FOURMOLU_DISABLE -}+#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH)+#define WINAPI ccall+#else+#define WINAPI stdcall+#endif++foreign import WINAPI unsafe "windows.h GetShortPathNameW"+  c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> Prelude.IO DWORD++-- | On Windows, retrieves the short path form of the specified path. On+-- non-Windows, does nothing. See https://github.com/haskell/cabal/issues/3185.+--+-- From MS's GetShortPathName docs:+--+--      Passing NULL for [the second] parameter and zero for cchBuffer+--      will always return the required buffer size for a+--      specified lpszLongPath.+--+getShortPathName :: FilePath -> IO FilePath+getShortPathName path =+  Win32.withTString path $ \c_path -> do+    c_len <- Win32.failIfZero "GetShortPathName #1 failed!" $+      c_GetShortPathName c_path Win32.nullPtr 0+    let arr_len = fromIntegral c_len+    allocaArray arr_len $ \c_out -> do+      void $ Win32.failIfZero "GetShortPathName #2 failed!" $+        c_GetShortPathName c_path c_out c_len+      Win32.peekTString c_out++#else++getShortPathName :: FilePath -> IO FilePath+getShortPathName path = return path++#endif+{- FOURMOLU_ENABLE -}
+ src/Distribution/Compat/Internal/TempFile.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}++module Distribution.Compat.Internal.TempFile+  ( openTempFile+  , openBinaryTempFile+  , openNewBinaryFile+  , createTempDirectory+  ) where++import Distribution.Compat.Exception++import System.FilePath ((</>))++import System.IO (Handle, openBinaryTempFile, openBinaryTempFileWithDefaultPermissions, openTempFile)+import System.IO.Error (isAlreadyExistsError)+import System.Posix.Internals (c_getpid)++#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)+import System.Directory       ( createDirectory )+#else+import qualified System.Posix+#endif++openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)+openNewBinaryFile = openBinaryTempFileWithDefaultPermissions++createTempDirectory :: FilePath -> String -> IO FilePath+createTempDirectory dir template = do+  pid <- c_getpid+  findTempName pid+  where+    findTempName x = do+      let relpath = template ++ "-" ++ show x+          dirpath = dir </> relpath+      r <- tryIO $ mkPrivateDir dirpath+      case r of+        Right _ -> return relpath+        Left e+          | isAlreadyExistsError e -> findTempName (x + 1)+          | otherwise -> ioError e++mkPrivateDir :: String -> IO ()+#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)+mkPrivateDir s = createDirectory s+#else+mkPrivateDir s = System.Posix.createDirectory s 0o700+#endif
+ src/Distribution/Compat/Prelude/Internal.hs view
@@ -0,0 +1,14 @@+-- | This module re-exports the non-exposed+-- "Distribution.Compat.Prelude" module for+-- reuse by @cabal-install@'s+-- "Distribution.Client.Compat.Prelude" module.+--+-- It is highly discouraged to rely on this module+-- 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++import Distribution.Compat.Prelude
+ src/Distribution/Compat/Process.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE CPP #-}++module Distribution.Compat.Process+  ( -- * Redefined functions+    proc++    -- * Additions+  , enableProcessJobs+  ) where++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)+import           System.Win32.Info.Version (dwMajorVersion, dwMinorVersion, getVersionEx)+#endif++-------------------------------------------------------------------------------+-- enableProcessJobs+-------------------------------------------------------------------------------++#if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9)+-- This exception, needed to support Windows 7, could be removed when+-- the lowest GHC version cabal supports is a GHC that doesn’t support+-- Windows 7 any more.+{-# NOINLINE isWindows8OrLater #-}+isWindows8OrLater :: Bool+isWindows8OrLater = unsafePerformIO $ do+  v <- getVersionEx+  pure $ (dwMajorVersion v, dwMinorVersion v) >= (6, 2)+#endif++-- | Enable process jobs to ensure accurate determination of process completion+-- in the presence of @exec(3)@ on Windows.+--+-- Unfortunately the process job support is badly broken in @process@ releases+-- prior to 1.6.9, so we disable it in these versions, despite the fact that+-- this means we may see sporadic build failures without jobs.+--+-- 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+-- 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+-- Windows 7 or before.+enableProcessJobs :: CreateProcess -> CreateProcess+#if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9)+enableProcessJobs cp = cp {Process.use_process_jobs = isWindows8OrLater}+#else+enableProcessJobs cp = cp+#endif++-------------------------------------------------------------------------------+-- process redefinitions+-------------------------------------------------------------------------------++-- | '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
@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-- Compatibility layer for GHC.ResponseFile+-- Implementation from base 4.12.0 is used.+-- http://hackage.haskell.org/package/base-4.12.0.0/src/LICENSE+module Distribution.Compat.ResponseFile (expandResponse, escapeArgs) where++import Distribution.Compat.Prelude++import GHC.ResponseFile (escapeArgs, unescapeArgs)++import Prelude ()++import System.FilePath+import System.IO (hPutStrLn, stderr)+import System.IO.Error++-- | 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+    recursionLimit = 100++    go :: Int -> FilePath -> [String] -> IO [String]+    go 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 x = return [x]++    readRecursively :: Int -> FilePath -> IO [String]+    readRecursively n f = go (n - 1) (takeDirectory f) =<< unescapeArgs <$> readFile f
+ src/Distribution/Compat/SnocList.hs view
@@ -0,0 +1,34 @@+-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Compat.SnocList+-- License     :  BSD3+--+-- Maintainer  :  cabal-dev@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- A very reversed list. Has efficient `snoc`+module Distribution.Compat.SnocList+  ( SnocList+  , runSnocList+  , snoc+  ) where++import Distribution.Compat.Prelude+import Prelude ()++newtype SnocList a = SnocList [a]++snoc :: SnocList a -> a -> SnocList a+snoc (SnocList xs) x = SnocList (x : xs)++runSnocList :: SnocList a -> [a]+runSnocList (SnocList xs) = reverse xs++instance Semigroup (SnocList a) where+  SnocList xs <> SnocList ys = SnocList (ys <> xs)++instance Monoid (SnocList a) where+  mempty = SnocList []+  mappend = (<>)
+ src/Distribution/Compat/Stack.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE RankNTypes #-}++module Distribution.Compat.Stack+  ( WithCallStack+  , CallStack+  , annotateCallStackIO+  , withFrozenCallStack+  , withLexicalCallStack+  , callStack+  , prettyCallStack+  , parentSrcLocPrefix+  ) where++import GHC.Stack+import System.IO.Error++type WithCallStack a = HasCallStack => a++-- | Give the *parent* of the person who invoked this;+-- so it's most suitable for being called from a utility function.+-- You probably want to call this using 'withFrozenCallStack'; otherwise+-- it's not very useful.  We didn't implement this for base-4.8.1+-- because we cannot rely on freezing to have taken place.+parentSrcLocPrefix :: WithCallStack String+parentSrcLocPrefix =+  case getCallStack callStack of+    (_ : (_, loc) : _) -> showLoc loc+    [(_, loc)] -> showLoc loc+    [] -> error "parentSrcLocPrefix: empty call stack"+  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++-- | This function is for when you *really* want to add a call+-- stack to raised IO, but you don't have a+-- 'Distribution.Verbosity.Verbosity' so you can't use+-- 'Distribution.Simple.Utils.annotateIO'.  If you have a 'Verbosity',+-- please use that function instead.+annotateCallStackIO :: WithCallStack (IO a -> IO a)+annotateCallStackIO = modifyIOError f+  where+    f ioe =+      ioeSetErrorString ioe+        . wrapCallStack+        $ ioeGetErrorString ioe+    wrapCallStack s =+      prettyCallStack callStack ++ "\n" ++ s
+ src/Distribution/Compat/Time.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Distribution.Compat.Time+  ( ModTime (..) -- Needed for testing+  , getModTime+  , getFileAge+  , getCurTime+  , posixSecondsToModTime+  , calibrateMtimeChangeDelay+  )+where++import Distribution.Compat.Prelude+import Prelude ()++import System.Directory (getModificationTime)++import Distribution.Simple.Utils (withTempDirectoryCwd)+import Distribution.Utils.Path (getSymbolicPath, sameDirectory)+import Distribution.Verbosity (silent)++import System.FilePath++import Data.Time (diffUTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixDayLength)++#if defined mingw32_HOST_OS++import qualified Prelude+import Data.Bits          ((.|.), unsafeShiftL)+import Data.Bits          (finiteBitSize)++import Foreign            ( allocaBytes, peekByteOff )+import System.IO.Error    ( mkIOError, doesNotExistErrorType )+import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString )++#else++import System.Posix.Files+  ( FileStatus, getFileStatus+#if MIN_VERSION_unix(2,6,0)+  , modificationTimeHiRes+#else+  , modificationTime+#endif+  )++#endif++-- | 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)++instance Structured ModTime++instance Show ModTime where+  show (ModTime x) = show x++instance Read ModTime where+  readsPrec p str = map (first ModTime) (readsPrec p str)++-- | Return modification time of the given file. Works around the low clock+-- resolution problem that 'getModificationTime' has on GHC < 7.8.+--+-- This is a modified version of the code originally written for Shake by Neil+-- Mitchell. See module Development.Shake.FileInfo.+getModTime :: FilePath -> IO ModTime++#if defined mingw32_HOST_OS++-- Directly against the Win32 API.+getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do+  res <- getFileAttributesEx path info+  if not res+    then do+      let err = mkIOError doesNotExistErrorType+                "Distribution.Compat.Time.getModTime"+                Nothing (Just path)+      ioError err+    else do+      dwLow  <- peekByteOff info+                index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime+      dwHigh <- peekByteOff info+                index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime+      let qwTime =+            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh)+            .|. (fromIntegral (dwLow :: DWORD))+      return $! ModTime (qwTime :: Word64)++{- FOURMOLU_DISABLE -}+#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH)+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif++foreign import CALLCONV "windows.h GetFileAttributesExW"+  c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> Prelude.IO BOOL++getFileAttributesEx :: String -> LPVOID -> IO BOOL+getFileAttributesEx path lpFileInformation =+  withTString path $ \c_path ->+      c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation++getFileExInfoStandard :: Int32+getFileExInfoStandard = 0++size_WIN32_FILE_ATTRIBUTE_DATA :: Int+size_WIN32_FILE_ATTRIBUTE_DATA = 36++index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int+index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20++index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int+index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24++#else++-- Directly against the unix library.+getModTime path = do+    st <- getFileStatus path+    return $! (extractFileTime st)++extractFileTime :: FileStatus -> ModTime+extractFileTime x = posixTimeToModTime (modificationTimeHiRes x)++#endif+{- FOURMOLU_ENABLE -}++windowsTick, secToUnixEpoch :: Word64+windowsTick = 10000000+secToUnixEpoch = 11644473600++-- | Convert POSIX seconds to ModTime.+posixSecondsToModTime :: Int64 -> ModTime+posixSecondsToModTime s =+  ModTime $ ((fromIntegral s :: Word64) + secToUnixEpoch) * windowsTick++-- | Convert 'POSIXTime' to 'ModTime'.+posixTimeToModTime :: POSIXTime -> ModTime+posixTimeToModTime p =+  ModTime $+    ceiling (p * 1e7) -- 100 ns precision+      + (secToUnixEpoch * windowsTick)++-- | Return age of given file in days.+getFileAge :: FilePath -> IO Double+getFileAge file = do+  t0 <- getModificationTime file+  t1 <- getCurrentTime+  return $ realToFrac (t1 `diffUTCTime` t0) / realToFrac posixDayLength++-- | Return the current time as 'ModTime'.+getCurTime :: IO ModTime+getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'.++-- | Based on code written by Neil Mitchell for Shake. See+-- 'sleepFileTimeCalibrate' in 'Test.Type'.  Returns a pair+-- of microsecond values: first, the maximum delay seen, and the+-- recommended delay to use before testing for file modification change.+-- The returned delay is never smaller+-- than 10 ms, but never larger than 1 second.+calibrateMtimeChangeDelay :: IO (Int, Int)+calibrateMtimeChangeDelay =+  withTempDirectoryCwd silent Nothing sameDirectory "calibration-" $ \dir -> do+    let fileName = getSymbolicPath dir </> "probe"+    mtimes <- for [1 .. 25] $ \(i :: Int) -> time $ do+      writeFile fileName $ show i+      t0 <- getModTime fileName+      let spin j = do+            writeFile fileName $ show (i, j)+            t1 <- getModTime fileName+            unless (t0 < t1) (spin $ j + 1)+      spin (0 :: Int)+    let mtimeChange = maximum mtimes+        mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2+    return (mtimeChange, mtimeChange')+  where+    time :: IO () -> IO Int+    time act = do+      t0 <- getCurrentTime+      act+      t1 <- getCurrentTime+      return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds
+ src/Distribution/GetOpt.hs view
@@ -0,0 +1,307 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TupleSections #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.GetOpt+-- Copyright   :  (c) Sven Panne 2002-2005+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- This is a fork of "System.Console.GetOpt" with the following changes:+--+-- * Treat "cabal --flag command" as "cabal command --flag" e.g.+--   "cabal -v configure" to mean "cabal configure -v" For flags that are+--   not recognised as global flags, pass them on to the sub-command. See+--   the difference in 'shortOpt'.+--+-- * Line wrapping in the 'usageInfo' output, plus a more compact+--   rendering of short options, and slightly less padding.+--+-- * Parsing of option arguments is allowed to fail.+--+-- * 'ReturnInOrder' argument order is removed.+module Distribution.GetOpt+  ( -- * GetOpt+    getOpt+  , getOpt'+  , usageInfo+  , ArgOrder (..)+  , OptDescr (..)+  , ArgDescr (..)++    -- * Example++    -- | See "System.Console.GetOpt" for examples+  ) where++import Distribution.Compat.Prelude+import Prelude ()++-- | 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 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 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)+        , optHelp = d+        }++    maxOptNameWidth = 30+    descolWidth = 80 - (maxOptNameWidth + 3)++    table :: [String]+    table = do+      OptHelp{optNames, optHelp} <- options+      let wrappedHelp = wrapText descolWidth optHelp+      if length optNames >= maxOptNameWidth+        then+          [" " ++ optNames]+            ++ renderColumns [] wrappedHelp+        else renderColumns [optNames] wrappedHelp++    renderColumns :: [String] -> [String] -> [String]+    renderColumns xs ys = do+      (x, y) <- zipDefault "" "" xs ys+      return $ " " ++ padTo maxOptNameWidth x ++ " " ++ y++    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++-- | 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 _ 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 =+  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').+--+-- 'getOpt' returns a triple consisting of the option arguments, a list+-- of non-options, and a list of error messages.+getOpt+  :: ArgOrder a -- non-option handling+  -> [OptDescr a] -- option descriptors+  -> [String] -- the command-line arguments+  -> ([a], [String], [String]) -- (options,non-options,error messages)+getOpt ordering optDescr args = (os, xs, es ++ map errUnrec us)+  where+    (os, xs, us, es) = getOpt' ordering optDescr args++-- |+-- This is almost the same as 'getOpt', but returns a quadruple+-- consisting of the option arguments, a list of non-options, a list of+-- unrecognized options, and a list of error messages.+getOpt'+  :: ArgOrder a -- non-option handling+  -> [OptDescr a] -- option descriptors+  -> [String] -- the command-line arguments+  -> ([a], [String], [String], [String]) -- (options,non-options,unrecognized,error messages)+getOpt' _ _ [] = ([], [], [], [])+getOpt' ordering optDescr (arg : args) = procNextOpt opt ordering+  where+    procNextOpt (Opt o) _ = (o : os, xs, us, es)+    procNextOpt (UnreqOpt u) _ = (os, xs, u : us, es)+    procNextOpt (NonOpt x) RequireOrder = ([], x : rest, [], [])+    procNextOpt (NonOpt x) Permute = (os, x : xs, us, es)+    procNextOpt EndOfOpts RequireOrder = ([], rest, [], [])+    procNextOpt EndOfOpts Permute = ([], rest, [], [])+    procNextOpt (OptErr e) _ = (os, xs, us, e : es)++    (opt, rest) = getNext arg args optDescr+    (os, xs, us, es) = getOpt' ordering optDescr rest++-- take a look at the next cmd line arg and decide what to do with it+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a, [String])+getNext ('-' : '-' : []) rest _ = (EndOfOpts, rest)+getNext ('-' : '-' : xs) rest optDescr = longOpt xs rest optDescr+getNext ('-' : x : xs) rest optDescr = shortOpt x xs rest optDescr+getNext a rest _ = (NonOpt a, rest)++-- handle long option+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a, [String])+longOpt ls rs optDescr = long ads arg rs+  where+    (opt, arg) = break (== '=') ls+    getWith p =+      [ o | o@(Option _ xs _ _) <- optDescr, isJust (find (p opt) xs)+      ]+    exact = getWith (==)+    options = if null exact then getWith isPrefixOf else exact+    ads = [ad | Option _ _ ad _ <- options]+    optStr = "--" ++ opt+    fromRes = fromParseResult optStr++    long (_ : _ : _) _ rest = (errAmbig options optStr, rest)+    long [NoArg a] [] rest = (Opt a, rest)+    long [NoArg _] ('=' : _) rest = (errNoArg optStr, rest)+    long [ReqArg _ d] [] [] = (errReq d optStr, [])+    long [ReqArg f _] [] (r : rest) = (fromRes (f r), rest)+    long [ReqArg f _] ('=' : xs) rest = (fromRes (f xs), rest)+    long [OptArg _ f _] [] rest = (fromRes (f Nothing), rest)+    long [OptArg _ f _] ('=' : xs) rest = (fromRes (f (Just xs)), rest)+    long _ _ rest = (UnreqOpt ("--" ++ ls), rest)++-- handle short option+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a, [String])+shortOpt y ys rs optDescr = short ads ys rs+  where+    options = [o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s]+    ads = [ad | Option _ _ ad _ <- options]+    optStr = '-' : [y]+    fromRes = fromParseResult optStr++    short (_ : _ : _) _ rest = (errAmbig options optStr, rest)+    short (NoArg a : _) [] rest = (Opt a, rest)+    short (NoArg a : _) xs rest = (Opt a, ('-' : xs) : rest)+    short (ReqArg _ d : _) [] [] = (errReq d optStr, [])+    short (ReqArg f _ : _) [] (r : rest) = (fromRes (f r), rest)+    short (ReqArg f _ : _) xs rest = (fromRes (f xs), rest)+    short (OptArg _ f _ : _) [] rest = (fromRes (f Nothing), rest)+    short (OptArg _ f _ : _) xs rest = (fromRes (f (Just xs)), rest)+    short [] [] rest = (UnreqOpt optStr, rest)+    short [] xs rest = (UnreqOpt (optStr ++ xs), rest)++-- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest)+-- Apparently this was part of the change so that flags that are+-- not recognised as global flags are passed on to the sub-command.+-- But why was no equivalent change required for longOpt? So could+-- this change go upstream?++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 b+errAmbig ods optStr = OptErr (usageInfo header ods)+  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")++errUnrec :: String -> String+errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"++errNoArg :: String -> OptKind a+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
+ src/Distribution/Lex.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Lex+-- Copyright   :  Ben Gamari 2015-2019+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module contains a simple lexer supporting quoted strings+module Distribution.Lex+  ( tokenizeQuotedWords+  ) where++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 _ accum []+      | [] <- accum' = []+      | 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
+ src/Distribution/Make.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++--                      copy :+--                              $(MAKE) install prefix=$(destdir)/$(prefix) \+--                                              bindir=$(destdir)/$(bindir) \++-- |+-- Module      :  Distribution.Make+-- Copyright   :  Martin Sj&#xF6;gren 2004+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This is an alternative build system that delegates everything to the @make@+-- program. All the commands just end up calling @make@ with appropriate+-- arguments. The intention was to allow preexisting packages that used+-- makefiles to be wrapped into Cabal packages. In practice essentially all+-- such packages were converted over to the \"Simple\" build system instead.+-- Consequently this module is not used much and it certainly only sees cursory+-- maintenance and no testing. Perhaps at some point we should stop pretending+-- that it works.+--+-- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build+-- Haskell tools using a back-end build system based on make. Obviously we+-- assume that there is a configure script, and that after the ConfigCmd has+-- been run, there is a Makefile. Further assumptions:+--+-- [ConfigCmd] We assume the configure script accepts+--              @--with-hc@,+--              @--with-hc-pkg@,+--              @--prefix@,+--              @--bindir@,+--              @--libdir@,+--              @--libexecdir@,+--              @--datadir@.+--+-- [BuildCmd] We assume that the default Makefile target will build everything.+--+-- [InstallCmd] We assume there is an @install@ target. Note that we assume that+-- this does *not* register the package!+--+-- [CopyCmd]    We assume there is a @copy@ target, and a variable @$(destdir)@.+--              The @copy@ target should probably just invoke @make install@+--              recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix)+--              bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make+--              install@ directly here is that we don\'t know the value of @$(prefix)@.+--+-- [SDistCmd] We assume there is a @dist@ target.+--+-- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@.+--+-- [UnregisterCmd] We assume there is an @unregister@ target.+--+-- [HaddockCmd] We assume there is a @docs@ or @doc@ target.+module Distribution.Make+  ( module Distribution.Package+  , License (..)+  , Version+  , defaultMain+  , defaultMainArgs+  ) where++import Distribution.Compat.Prelude+import Prelude ()++-- local+import Distribution.License+import Distribution.Package+import Distribution.Pretty+import Distribution.Simple.Command+import Distribution.Simple.Program+import Distribution.Simple.Setup+import Distribution.Simple.Utils+import Distribution.Version++import System.Environment (getArgs, getProgName)++defaultMain :: IO ()+defaultMain = getArgs >>= defaultMainArgs++defaultMainArgs :: [String] -> IO ()+defaultMainArgs = defaultMainHelper++defaultMainHelper :: [String] -> IO ()+defaultMainHelper args = do+  command <- commandsRun (globalCommand commands) commands args+  case command of+    CommandHelp help -> printHelp help+    CommandList opts -> printOptionsList opts+    CommandErrors errs -> printErrors errs+    CommandReadyToGo (flags, commandParse) ->+      case commandParse of+        _+          | fromFlag (globalVersion flags) -> printVersion+          | fromFlag (globalNumericVersion flags) -> printNumericVersion+        CommandHelp help -> printHelp help+        CommandList opts -> printOptionsList opts+        CommandErrors errs -> printErrors errs+        CommandReadyToGo action -> action+  where+    printHelp help = getProgName >>= putStr . help+    printOptionsList = putStr . unlines+    printErrors errs = do+      putStr (intercalate "\n" errs)+      exitWith (ExitFailure 1)+    printNumericVersion = putStrLn $ prettyShow cabalVersion+    printVersion =+      putStrLn $+        "Cabal library version "+          ++ prettyShow cabalVersion+    progs = defaultProgramDb+    commands =+      [ configureCommand progs `commandAddAction` configureAction+      , buildCommand progs `commandAddAction` buildAction+      , installCommand `commandAddAction` installAction+      , copyCommand `commandAddAction` copyAction+      , haddockCommand `commandAddAction` haddockAction+      , cleanCommand `commandAddAction` cleanAction+      , sdistCommand `commandAddAction` sdistAction+      , registerCommand `commandAddAction` registerAction+      , unregisterCommand `commandAddAction` unregisterAction+      ]++configureAction :: ConfigFlags -> [String] -> IO ()+configureAction flags args = do+  noExtraFlags args+  let verbosity = fromFlag $ configVerbosity flags+      mbWorkDir = flagToMaybe $ configWorkingDir flags+  rawSystemExit verbosity mbWorkDir "sh" $+    "configure"+      : configureArgs backwardsCompatHack flags+  where+    backwardsCompatHack = True++copyAction :: CopyFlags -> [String] -> IO ()+copyAction flags args = do+  noExtraFlags args+  let verbosity = fromFlag $ copyVerbosity flags+      mbWorkDir = flagToMaybe $ copyWorkingDir flags+      destArgs = case fromFlag $ copyDest flags of+        NoCopyDest -> ["install"]+        CopyTo path -> ["copy", "destdir=" ++ path]+        CopyToDb _ -> error "CopyToDb not supported via Make"++  rawSystemExit verbosity mbWorkDir "make" destArgs++installAction :: InstallFlags -> [String] -> IO ()+installAction flags args = do+  noExtraFlags args+  let verbosity = fromFlag $ installVerbosity flags+      mbWorkDir = flagToMaybe $ installWorkingDir flags+  rawSystemExit verbosity mbWorkDir "make" ["install"]+  rawSystemExit verbosity mbWorkDir "make" ["register"]++haddockAction :: HaddockFlags -> [String] -> IO ()+haddockAction flags args = do+  noExtraFlags args+  let verbosity = fromFlag $ haddockVerbosity flags+      mbWorkDir = flagToMaybe $ haddockWorkingDir flags+  rawSystemExit verbosity mbWorkDir "make" ["docs"]+    `catchIO` \_ ->+      rawSystemExit verbosity mbWorkDir "make" ["doc"]++buildAction :: BuildFlags -> [String] -> IO ()+buildAction flags args = do+  noExtraFlags args+  let verbosity = fromFlag $ buildVerbosity flags+      mbWorkDir = flagToMaybe $ buildWorkingDir flags+  rawSystemExit verbosity mbWorkDir "make" []++cleanAction :: CleanFlags -> [String] -> IO ()+cleanAction flags args = do+  noExtraFlags args+  let verbosity = fromFlag $ cleanVerbosity flags+      mbWorkDir = flagToMaybe $ cleanWorkingDir flags+  rawSystemExit verbosity mbWorkDir "make" ["clean"]++sdistAction :: SDistFlags -> [String] -> IO ()+sdistAction flags args = do+  noExtraFlags args+  let verbosity = fromFlag $ sDistVerbosity flags+      mbWorkDir = flagToMaybe $ sDistWorkingDir flags+  rawSystemExit verbosity mbWorkDir "make" ["dist"]++registerAction :: RegisterFlags -> [String] -> IO ()+registerAction flags args = do+  noExtraFlags args+  let verbosity = fromFlag $ registerVerbosity flags+      mbWorkDir = flagToMaybe $ registerWorkingDir flags+  rawSystemExit verbosity mbWorkDir "make" ["register"]++unregisterAction :: RegisterFlags -> [String] -> IO ()+unregisterAction flags args = do+  noExtraFlags args+  let verbosity = fromFlag $ registerVerbosity flags+      mbWorkDir = flagToMaybe $ registerWorkingDir flags+  rawSystemExit verbosity mbWorkDir "make" ["unregister"]
+ src/Distribution/PackageDescription/Check.hs view
@@ -0,0 +1,1111 @@+{-# 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/ReadE.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE LambdaCase #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.ReadE+-- Copyright   :  Jose Iborra 2008+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Simple parsing with failure+module Distribution.ReadE+  ( -- * ReadE+    ReadE (..)+  , succeedReadE+  , failReadE++    -- * 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++instance Functor ReadE where+  fmap f (ReadE p) = ReadE $ \txt -> case p txt of+    Right a -> Right (f a)+    Left err -> Left err++succeedReadE :: (String -> a) -> ReadE a+succeedReadE f = ReadE (Right . f)++failReadE :: ErrorMsg -> ReadE a+failReadE = ReadE . const . Left++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 ->+  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/Simple.hs view
@@ -0,0 +1,1132 @@+{-# 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
@@ -0,0 +1,180 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Bench+-- Copyright   :  Johan Tibell 2011+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- 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++import Distribution.Compat.Prelude+import Prelude ()++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.Program.Db+import Distribution.Simple.Program.Find+import Distribution.Simple.Program.Run+import Distribution.Simple.Setup.Benchmark+import Distribution.Simple.Setup.Common+import Distribution.Simple.UserHooks+import Distribution.Simple.Utils+import Distribution.System (Platform (Platform))+import Distribution.Types.Benchmark (Benchmark (benchmarkBuildInfo))+import Distribution.Types.UnqualComponentName+import Distribution.Utils.Path++import 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 pkg_descr lbi flags = do+  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, 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++            -- Compute the appropriate environment for running the benchmark+            let progDb = LBI.withPrograms lbiForBench+                pathVar = progSearchPath progDb+                envOverrides = progOverrideEnv progDb+            newPath <- programSearchPathAsPATHVar pathVar+            shellEnv <- getFullEnvironment ([("PATH", Just newPath)] ++ envOverrides)++            -- Add (DY)LD_LIBRARY_PATH if needed+            shellEnv' <-+              if LBI.withDynExe lbiForBench+                then do+                  let (Platform _ os) = LBI.hostPlatform lbiForBench+                  paths <- LBI.depLibraryPaths True False lbiForBench clbi+                  return (addLibraryPath os paths shellEnv)+                else return shellEnv++            notice verbosity $ startMessage name+            -- This will redirect the child process+            -- stdout/stderr to the parent process.+            exitcode <- rawSystemExitCode verbosity 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++  unless (PD.hasBenchmarks pkg_descr) $ do+    notice verbosity "Package has no benchmarks."+    exitSuccess++  when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $+    dieWithException verbosity EnableBenchMark++  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"+           )++-- 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 pkg_descr lbi bm 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)]
+ src/Distribution/Simple/Build.hs view
@@ -0,0 +1,1240 @@+{-# 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
@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Build.Macros+-- Copyright   :  Simon Marlow 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Generate cabal_macros.h - CPP macros for package version testing+--+-- When using CPP you get+--+-- > VERSION_<package>+-- > MIN_VERSION_<package>(A,B,C)+--+-- for each /package/ in @build-depends@, which is true if the version of+-- /package/ in use is @>= A.B.C@, using the normal ordering on version+-- numbers.+--+-- TODO Figure out what to do about backpack and internal libraries. It is very+-- suspicious that this stuff works with munged package identifiers+module Distribution.Simple.Build.Macros+  ( generateCabalMacrosHeader+  , generatePackageVersionMacros+  ) where++import Distribution.Compat.Prelude+import Prelude ()++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.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+            , Z.ztoolVersion = ver+            , 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 = 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++-- | 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+      }++mkZPackage :: PackageId -> Z.ZPackage+mkZPackage (PackageIdentifier name ver) =+  Z.ZPackage+    { Z.zpkgName = name+    , Z.zpkgVersion = ver+    , Z.zpkgX = major1+    , Z.zpkgY = major2+    , Z.zpkgZ = minor+    }+  where+    (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)++fixchar :: Char -> Char+fixchar '-' = '_'+fixchar c = c
+ src/Distribution/Simple/Build/Macros/Z.hs view
@@ -0,0 +1,141 @@+{- 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],+         zPackageKey :: String,+         zComponentId :: String,+         zPackageVersion :: Version,+         zNotNull :: (String -> Bool),+         zManglePkgName :: (PackageName -> String),+         zMangleStr :: (String -> String)}+    deriving Generic+data ZPackage+    = ZPackage {zpkgName :: PackageName,+                zpkgVersion :: Version,+                zpkgX :: String,+                zpkgY :: String,+                zpkgZ :: String}+    deriving Generic+data ZTool+    = ZTool {ztoolName :: String,+             ztoolVersion :: Version,+             ztoolX :: String,+             ztoolY :: String,+             ztoolZ :: String}+    deriving Generic+render :: Z -> String+render z_root = execWriter $ do+  tell "/* DO NOT EDIT: This file is automatically generated by Cabal */\n"+  tell "\n"+  forM_ (zPackages z_root) $ \z_var0_pkg -> do+    tell "/* package "+    tell (prettyShow (zpkgName z_var0_pkg))+    tell "-"+    tell (prettyShow (zpkgVersion z_var0_pkg))+    tell " */\n"+    tell "#ifndef VERSION_"+    tell (zManglePkgName z_root (zpkgName z_var0_pkg))+    tell "\n"+    tell "#define VERSION_"+    tell (zManglePkgName z_root (zpkgName z_var0_pkg))+    tell " \""+    tell (prettyShow (zpkgVersion z_var0_pkg))+    tell "\"\n"+    tell "#endif /* VERSION_"+    tell (zManglePkgName z_root (zpkgName z_var0_pkg))+    tell " */\n"+    tell "#ifndef MIN_VERSION_"+    tell (zManglePkgName z_root (zpkgName z_var0_pkg))+    tell "\n"+    tell "#define MIN_VERSION_"+    tell (zManglePkgName z_root (zpkgName z_var0_pkg))+    tell "(major1,major2,minor) (\\\n"+    tell "  (major1) <  "+    tell (zpkgX z_var0_pkg)+    tell " || \\\n"+    tell "  (major1) == "+    tell (zpkgX z_var0_pkg)+    tell " && (major2) <  "+    tell (zpkgY z_var0_pkg)+    tell " || \\\n"+    tell "  (major1) == "+    tell (zpkgX z_var0_pkg)+    tell " && (major2) == "+    tell (zpkgY z_var0_pkg)+    tell " && (minor) <= "+    tell (zpkgZ z_var0_pkg)+    tell ")\n"+    tell "#endif /* MIN_VERSION_"+    tell (zManglePkgName z_root (zpkgName z_var0_pkg))+    tell " */\n"+  tell "\n"+  forM_ (zTools z_root) $ \z_var1_tool -> do+    tell "/* tool "+    tell (ztoolName z_var1_tool)+    tell "-"+    tell (prettyShow (ztoolVersion z_var1_tool))+    tell " */\n"+    tell "#ifndef TOOL_VERSION_"+    tell (zMangleStr z_root (ztoolName z_var1_tool))+    tell "\n"+    tell "#define TOOL_VERSION_"+    tell (zMangleStr z_root (ztoolName z_var1_tool))+    tell " \""+    tell (prettyShow (ztoolVersion z_var1_tool))+    tell "\"\n"+    tell "#endif /* TOOL_VERSION_"+    tell (zMangleStr z_root (ztoolName z_var1_tool))+    tell " */\n"+    tell "#ifndef MIN_TOOL_VERSION_"+    tell (zMangleStr z_root (ztoolName z_var1_tool))+    tell "\n"+    tell "#define MIN_TOOL_VERSION_"+    tell (zMangleStr z_root (ztoolName z_var1_tool))+    tell "(major1,major2,minor) (\\\n"+    tell "  (major1) <  "+    tell (ztoolX z_var1_tool)+    tell " || \\\n"+    tell "  (major1) == "+    tell (ztoolX z_var1_tool)+    tell " && (major2) <  "+    tell (ztoolY z_var1_tool)+    tell " || \\\n"+    tell "  (major1) == "+    tell (ztoolX z_var1_tool)+    tell " && (major2) == "+    tell (ztoolY z_var1_tool)+    tell " && (minor) <= "+    tell (ztoolZ z_var1_tool)+    tell ")\n"+    tell "#endif /* MIN_TOOL_VERSION_"+    tell (zMangleStr z_root (ztoolName z_var1_tool))+    tell " */\n"+  tell "\n"+  if (zNotNull z_root (zPackageKey z_root))+  then do+    tell "#ifndef CURRENT_PACKAGE_KEY\n"+    tell "#define CURRENT_PACKAGE_KEY \""+    tell (zPackageKey z_root)+    tell "\"\n"+    tell "#endif /* CURRENT_packageKey */\n"+    return ()+  else do+    return ()+  if (zNotNull z_root (zComponentId z_root))+  then do+    tell "#ifndef CURRENT_COMPONENT_ID\n"+    tell "#define CURRENT_COMPONENT_ID \""+    tell (zComponentId z_root)+    tell "\"\n"+    tell "#endif /* CURRENT_COMPONENT_ID */\n"+    return ()+  else do+    return ()+  tell "#ifndef CURRENT_PACKAGE_VERSION\n"+  tell "#define CURRENT_PACKAGE_VERSION \""+  tell (prettyShow (zPackageVersion z_root))+  tell "\"\n"+  tell "#endif /* CURRENT_PACKAGE_VERSION */\n"
+ 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
@@ -0,0 +1,170 @@+-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Build.Macros+-- Copyright   :  Isaac Jones 2003-2005,+--                Ross Paterson 2006,+--                Duncan Coutts 2007-2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Generating the Paths_pkgname module.+--+-- 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+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Package+import Distribution.PackageDescription+import Distribution.Simple.Compiler+import Distribution.Simple.LocalBuildInfo+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.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])++    ghc_newer_than minVersion =+      case compilerCompatVersion GHC (compiler lbi) of+        Nothing -> False+        Just version -> version `withinRange` orLaterVersion minVersion++    -- In several cases we cannot make relocatable installations+    absolute =+      hasLibs pkg_descr -- we can only make progs relocatable+        || 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++    supportsRelocatableProgs GHC = isWindows+    supportsRelocatableProgs GHCJS = isWindows+    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++    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++    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"++    mkGetDir :: FilePath -> Maybe FilePath -> String+    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_libexecdir_reloc = shortRelativePath flat_prefix flat_libexecdir+    flat_sysconfdir_reloc = shortRelativePath flat_prefix flat_sysconfdir++-- | Generates the name of the environment variable controlling the path+-- component of interest.+--+-- 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+pkgPathEnvVar pkg_descr var =+  showPkgName (packageName pkg_descr) ++ "_" ++ var++showPkgName :: PackageName -> String+showPkgName = map fixchar . unPackageName++fixchar :: Char -> Char+fixchar '-' = '_'+fixchar c = c
+ src/Distribution/Simple/Build/PathsModule/Z.hs view
@@ -0,0 +1,406 @@+{- FOURMOLU_DISABLE -}+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Simple.Build.PathsModule.Z (render, Z(..)) where+import Distribution.ZinzaPrelude+data Z+    = Z {zPackageName :: PackageName,+         zVersionDigits :: String,+         zSupportsCpp :: Bool,+         zSupportsNoRebindableSyntax :: Bool,+         zAbsolute :: Bool,+         zRelocatable :: Bool,+         zIsWindows :: Bool,+         zIsI386 :: Bool,+         zIsX8664 :: Bool,+         zIsAArch64 :: Bool,+         zPrefix :: FilePath,+         zBindir :: FilePath,+         zLibdir :: FilePath,+         zDynlibdir :: FilePath,+         zDatadir :: FilePath,+         zLibexecdir :: FilePath,+         zSysconfdir :: FilePath,+         zNot :: (Bool -> Bool),+         zManglePkgName :: (PackageName -> String)}+    deriving Generic+render :: Z -> String+render z_root = execWriter $ do+  if (zSupportsCpp z_root)+  then do+    tell "{-# LANGUAGE CPP #-}\n"+    return ()+  else do+    return ()+  if (zSupportsNoRebindableSyntax z_root)+  then do+    tell "{-# LANGUAGE NoRebindableSyntax #-}\n"+    return ()+  else do+    return ()+  if (zNot z_root (zAbsolute z_root))+  then do+    tell "{-# LANGUAGE ForeignFunctionInterface #-}\n"+    return ()+  else do+    return ()+  if (zSupportsCpp z_root)+  then do+    tell "#if __GLASGOW_HASKELL__ >= 810\n"+    tell "{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}\n"+    tell "#endif\n"+    return ()+  else do+    return ()+  tell "{-# OPTIONS_GHC -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"+  tell "    version,\n"+  tell "    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,\n"+  tell "    getDataFileName, getSysconfDir\n"+  tell "  ) where\n"+  tell "\n"+  if (zNot z_root (zAbsolute z_root))+  then do+    tell "import Foreign\n"+    tell "import Foreign.C\n"+    return ()+  else do+    return ()+  tell "\n"+  tell "import qualified Control.Exception as Exception\n"+  tell "import Data.Version (Version(..))\n"+  tell "import System.Environment (getEnv)\n"+  tell "import Prelude\n"+  tell "\n"+  if (zRelocatable z_root)+  then do+    tell "import System.Environment (getExecutablePath)\n"+    return ()+  else do+    return ()+  tell "\n"+  if (zSupportsCpp z_root)+  then do+    tell "#if defined(VERSION_base)\n"+    tell "\n"+    tell "#if MIN_VERSION_base(4,0,0)\n"+    tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"+    tell "#else\n"+    tell "catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a\n"+    tell "#endif\n"+    tell "\n"+    tell "#else\n"+    tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"+    tell "#endif\n"+    tell "catchIO = Exception.catch\n"+    return ()+  else do+    tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"+    tell "catchIO = Exception.catch\n"+    return ()+  tell "\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 "-- |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"+    tell "getPrefixDirReloc :: FilePath -> IO FilePath\n"+    tell "getPrefixDirReloc dirRel = do\n"+    tell "  exePath <- getExecutablePath\n"+    tell "  let (dir,_) = splitFileName exePath\n"+    tell "  return ((dir `minusFileName` "+    tell (zBindir z_root)+    tell ") `joinFileName` dirRel)\n"+    tell "\n"+    tell "getBinDir     = catchIO (getEnv \""+    tell (zManglePkgName z_root (zPackageName z_root))+    tell "_bindir\")     (\\_ -> getPrefixDirReloc $ "+    tell (zBindir z_root)+    tell ")\n"+    tell "getLibDir     = catchIO (getEnv \""+    tell (zManglePkgName z_root (zPackageName z_root))+    tell "_libdir\")     (\\_ -> getPrefixDirReloc $ "+    tell (zLibdir z_root)+    tell ")\n"+    tell "getDynLibDir  = catchIO (getEnv \""+    tell (zManglePkgName z_root (zPackageName z_root))+    tell "_dynlibdir\")  (\\_ -> getPrefixDirReloc $ "+    tell (zDynlibdir z_root)+    tell ")\n"+    tell "getDataDir    = catchIO (getEnv \""+    tell (zManglePkgName z_root (zPackageName z_root))+    tell "_datadir\")    (\\_ -> getPrefixDirReloc $ "+    tell (zDatadir z_root)+    tell ")\n"+    tell "getLibexecDir = catchIO (getEnv \""+    tell (zManglePkgName z_root (zPackageName z_root))+    tell "_libexecdir\") (\\_ -> getPrefixDirReloc $ "+    tell (zLibexecdir z_root)+    tell ")\n"+    tell "getSysconfDir = catchIO (getEnv \""+    tell (zManglePkgName z_root (zPackageName z_root))+    tell "_sysconfdir\") (\\_ -> getPrefixDirReloc $ "+    tell (zSysconfdir z_root)+    tell ")\n"+    tell "\n"+    z_var0_function_defs+    tell "\n"+    return ()+  else do+    if (zAbsolute z_root)+    then do+      tell "\n"+      tell "bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath\n"+      tell "bindir     = "+      tell (zBindir z_root)+      tell "\n"+      tell "libdir     = "+      tell (zLibdir z_root)+      tell "\n"+      tell "dynlibdir  = "+      tell (zDynlibdir z_root)+      tell "\n"+      tell "datadir    = "+      tell (zDatadir z_root)+      tell "\n"+      tell "libexecdir = "+      tell (zLibexecdir z_root)+      tell "\n"+      tell "sysconfdir = "+      tell (zSysconfdir z_root)+      tell "\n"+      tell "\n"+      tell "getBinDir     = catchIO (getEnv \""+      tell (zManglePkgName z_root (zPackageName z_root))+      tell "_bindir\")     (\\_ -> return bindir)\n"+      tell "getLibDir     = catchIO (getEnv \""+      tell (zManglePkgName z_root (zPackageName z_root))+      tell "_libdir\")     (\\_ -> return libdir)\n"+      tell "getDynLibDir  = catchIO (getEnv \""+      tell (zManglePkgName z_root (zPackageName z_root))+      tell "_dynlibdir\")  (\\_ -> return dynlibdir)\n"+      tell "getDataDir    = catchIO (getEnv \""+      tell (zManglePkgName z_root (zPackageName z_root))+      tell "_datadir\")    (\\_ -> return datadir)\n"+      tell "getLibexecDir = catchIO (getEnv \""+      tell (zManglePkgName z_root (zPackageName z_root))+      tell "_libexecdir\") (\\_ -> return libexecdir)\n"+      tell "getSysconfDir = catchIO (getEnv \""+      tell (zManglePkgName z_root (zPackageName z_root))+      tell "_sysconfdir\") (\\_ -> return sysconfdir)\n"+      tell "\n"+      return ()+    else do+      if (zIsWindows z_root)+      then do+        tell "\n"+        tell "prefix :: FilePath\n"+        tell "prefix = "+        tell (zPrefix z_root)+        tell "\n"+        tell "\n"+        tell "getBinDir     = getPrefixDirRel $ "+        tell (zBindir z_root)+        tell "\n"+        tell "getLibDir     = "+        tell (zLibdir z_root)+        tell "\n"+        tell "getDynLibDir  = "+        tell (zDynlibdir z_root)+        tell "\n"+        tell "getDataDir    = catchIO (getEnv \""+        tell (zManglePkgName z_root (zPackageName z_root))+        tell "_datadir\")    (\\_ -> "+        tell (zDatadir z_root)+        tell ")\n"+        tell "getLibexecDir = "+        tell (zLibexecdir z_root)+        tell "\n"+        tell "getSysconfDir = "+        tell (zSysconfdir z_root)+        tell "\n"+        tell "\n"+        tell "getPrefixDirRel :: FilePath -> IO FilePath\n"+        tell "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"+        tell "  where\n"+        tell "    try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n"+        tell "        ret <- c_GetModuleFileName nullPtr buf size\n"+        tell "        case ret of\n"+        tell "          0 -> return (prefix `joinFileName` dirRel)\n"+        tell "          _ | ret < size -> do\n"+        tell "              exePath <- peekCWString buf\n"+        tell "              let (bindir,_) = splitFileName exePath\n"+        tell "              return ((bindir `minusFileName` "+        tell (zBindir z_root)+        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"+          tell "  c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n"+          return ()+        else do+          if (zIsX8664 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+            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"+        return ()+      else do+        tell "\n"+        tell "notRelocAbsoluteOrWindows :: ()\n"+        tell "notRelocAbsoluteOrWindows = _\n"+        tell "\n"+        return ()+      return ()+    return ()+  tell "\n"+  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@(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)+  then do+    tell "pathSeparator = '\\\\'\n"+    return ()+  else do+    tell "pathSeparator = '/'\n"+    return ()+  tell "\n"+  tell "isPathSeparator :: Char -> Bool\n"+  if (zIsWindows z_root)+  then do+    tell "isPathSeparator c = c == '/' || c == '\\\\'\n"+    return ()+  else do+    tell "isPathSeparator c = c == '/'\n"+    return ()
+ src/Distribution/Simple/BuildPaths.hs view
@@ -0,0 +1,462 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.BuildPaths+-- Copyright   :  Isaac Jones 2003-2004,+--                Duncan Coutts 2008+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- A bunch of dirs, paths and file names used for intermediate build steps.+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++    -- * Source files & build directories+  , getSourceFiles+  , getLibSourceFiles+  , getExeSourceFiles+  , getTestSourceFiles+  , getBenchmarkSourceFiles+  , getFLibSourceFiles+  , exeBuildDir+  , flibBuildDir+  , stubName+  , testBuildDir+  , benchmarkBuildDir+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Data.List (stripPrefix)+import Distribution.Compiler+import Distribution.ModuleName as ModuleName+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Pretty+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 Distribution.Verbosity++-- ---------------------------------------------------------------------------+-- Build directories and files++srcPref :: FilePath -> FilePath+srcPref distPref = distPref </> "src"++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+  -> 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 -> 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 -> 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.++cppHeaderName :: String+cppHeaderName = "cabal_macros.h"++-- | The name of the auto-generated Paths_* module associated with a package+autogenPathsModuleName :: PackageDescription -> ModuleName+autogenPathsModuleName pkg_descr =+  ModuleName.fromString $+    "Paths_" ++ map fixchar (prettyShow (packageName pkg_descr))+  where+    fixchar '-' = '_'+    fixchar c = c++-- | The name of the auto-generated PackageInfo_* module associated with a package+autogenPackageInfoModuleName :: PackageDescription -> ModuleName+autogenPackageInfoModuleName pkg_descr =+  ModuleName.fromString $+    "PackageInfo_" ++ map fixchar (prettyShow (packageName pkg_descr))+  where+    fixchar '-' = '_'+    fixchar c = c++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, SymbolicPath Pkg File)]+getLibSourceFiles verbosity lbi lib clbi =+  getSourceFiles verbosity mbWorkDir searchpaths modules+  where+    bi = libBuildInfo lib+    modules = allLibModules lib clbi+    mbWorkDir = mbWorkDirLBI lbi+    searchpaths =+      coerceSymbolicPath (componentBuildDir lbi clbi)+        : hsSourceDirs bi+        ++ [ autogenComponentModulesDir lbi clbi+           , autogenPackageModulesDir lbi+           ]++getExeSourceFiles+  :: Verbosity+  -> LocalBuildInfo+  -> Executable+  -> ComponentLocalBuildInfo+  -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)]+getExeSourceFiles verbosity lbi exe clbi = do+  moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules+  srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) (modulePath exe)+  return ((ModuleName.main, srcMainPath) : moduleFiles)+  where+    mbWorkDir = mbWorkDirLBI lbi+    bi = buildInfo exe+    modules = otherModules bi+    searchpaths =+      autogenComponentModulesDir lbi clbi+        : autogenPackageModulesDir lbi+        : coerceSymbolicPath (exeBuildDir lbi exe)+        : hsSourceDirs bi++getTestSourceFiles+  :: Verbosity+  -> LocalBuildInfo+  -> TestSuite+  -> ComponentLocalBuildInfo+  -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)]+getTestSourceFiles verbosity lbi test@TestSuite{testInterface = TestSuiteExeV10 _ path} clbi = do+  moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules+  srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) path+  return ((ModuleName.main, srcMainPath) : moduleFiles)+  where+    mbWorkDir = mbWorkDirLBI lbi+    bi = testBuildInfo test+    modules = otherModules bi+    searchpaths =+      autogenComponentModulesDir lbi clbi+        : autogenPackageModulesDir lbi+        : coerceSymbolicPath (testBuildDir lbi test)+        : hsSourceDirs bi+getTestSourceFiles _ _ _ _ = return []++getBenchmarkSourceFiles+  :: Verbosity+  -> LocalBuildInfo+  -> Benchmark+  -> ComponentLocalBuildInfo+  -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)]+getBenchmarkSourceFiles verbosity lbi bench@Benchmark{benchmarkInterface = BenchmarkExeV10 _ path} clbi = do+  moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules+  srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) path+  return ((ModuleName.main, srcMainPath) : moduleFiles)+  where+    mbWorkDir = mbWorkDirLBI lbi+    bi = benchmarkBuildInfo bench+    modules = otherModules bi+    searchpaths =+      autogenComponentModulesDir lbi clbi+        : autogenPackageModulesDir lbi+        : coerceSymbolicPath (benchmarkBuildDir lbi bench)+        : hsSourceDirs bi+getBenchmarkSourceFiles _ _ _ _ = return []++getFLibSourceFiles+  :: Verbosity+  -> LocalBuildInfo+  -> ForeignLib+  -> ComponentLocalBuildInfo+  -> IO [(ModuleName.ModuleName, 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 -> 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 -> 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++-- | Create a library name for a static library from a given name.+-- Prepends @lib@ and appends the static library extension (@.a@).+mkGenericStaticLibName :: String -> String+mkGenericStaticLibName lib = "lib" ++ lib <.> "a"++mkLibName :: UnitId -> String+mkLibName lib = mkGenericStaticLibName (getHSLibraryName lib)++mkProfLibName :: UnitId -> String+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++-- 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)++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++-- | Create a library name for a bundled shared library from a given name.+-- This matches the naming convention for shared libraries as implemented in+-- GHC's packageHsLibs function in the Packages module.+-- If the given name is prefixed with HS, then this prepends 'lib' and appends+-- the compiler flavour/version and shared library extension e.g.:+--     "HSrts-1.0" -> "libHSrts-1.0-ghc8.7.20190109.so"+-- Otherwise the given name should be prefixed with 'C', then this strips the+-- 'C', prepends 'lib' and appends the shared library extension e.g.:+--     "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)++-- ------------------------------------------------------------++-- * Platform file extensions++-- ------------------------------------------------------------++-- | Default extension for executable files on the current platform.+-- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)+exeExtension :: Platform -> String+exeExtension platform = case platform of+  Platform _ Windows -> "exe"+  Platform Wasm32 _ -> "wasm"+  _ -> ""++-- | Extension for object files. For GHC the extension is @\"o\"@.+objExtension :: String+objExtension = "o"++-- | Extension for dynamically linked (or shared) libraries+-- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows)+dllExtension :: Platform -> String+dllExtension (Platform _arch os) = case os of+  Windows -> "dll"+  OSX -> "dylib"+  _ -> "so"++-- | Extension for static libraries+--+-- TODO: Here, as well as in dllExtension, it's really the target OS that we're+-- interested in, not the build OS.+staticLibExtension :: Platform -> String+staticLibExtension (Platform _arch os) = case os of+  Windows -> "lib"+  _ -> "a"
+ src/Distribution/Simple/BuildTarget.hs view
@@ -0,0 +1,1110 @@+{-# 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
@@ -0,0 +1,113 @@+-- |+--+-- This modules provides functions for working with both the legacy+-- "build-tools" field, and its replacement, "build-tool-depends". Prefer using+-- the functions contained to access those fields directly.+module Distribution.Simple.BuildToolDepends where++import Distribution.Compat.Prelude+import Prelude ()++import qualified Data.Map as Map++import Distribution.Package+import Distribution.PackageDescription++-- | 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 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.+--+-- 2. The name in build-tools matches a hard-coded set of known tools.  For now,+--    the executable dependency produced is one an executable in a package of+--    the same, but the hard-coding could just as well be per-key.+--+-- The first cases matches first.+desugarBuildTool+  :: PackageDescription+  -> LegacyExeDependency+  -> Maybe ExeDependency+desugarBuildTool pkg led =+  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 pkg bi =+  buildToolDepends bi ++ mapMaybe (desugarBuildTool pkg) (buildTools bi)++-- | Does the given executable dependency map to this current package?+--+-- This is a tiny function, but used in a number of places.+--+-- This function is only sound to call on `BuildInfo`s from the given package+-- description. This is because it just filters the package names of each+-- dependency, and does not check whether version bounds in fact exclude the+-- current package, or the referenced components in fact exist in the current+-- package.+--+-- This is OK because when a package is loaded, it is checked (in+-- `Distribution.Package.Check`) that dependencies matching internal components+-- do indeed have version bounds accepting the current package, and any+-- depended-on component in the current package actually exists. In fact this+-- check is performed by gathering the internal tool dependencies of each+-- component of the package according to this module, and ensuring those+-- properties on each so-gathered dependency.+--+-- version bounds and components of the package are unchecked. This is because+-- we sanitize exe deps so that the matching name implies these other+-- conditions.+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 pkg bi =+  [ toolname+  | dep@(ExeDependency _ toolname _) <- getAllToolDependencies pkg bi+  , isInternal pkg dep+  ]
+ 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
@@ -0,0 +1,137 @@+-----------------------------------------------------------------------------++{-+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Isaac Jones nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++-- |+-- Module      :  Distribution.Simple.CCompiler+-- 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 Distribution.Compat.Prelude+import Prelude ()++import System.FilePath+  ( 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)++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++-- | 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"+  ]++-- | 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 False = "i"+cDialectFilenameExtension ObjectiveC True = "m"+cDialectFilenameExtension ObjectiveC False = "mi"+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+  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)+    "mii" -> return (ObjectiveCPlusPlus, False)+    "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
+ src/Distribution/Simple/Command.hs view
@@ -0,0 +1,801 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Command+-- Copyright   :  Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  non-portable (ExistentialQuantification)+--+-- This is to do with command line handling. The Cabal command line is+-- organised into a number of named sub-commands (much like darcs). The+-- 'CommandUI' abstraction represents one of these sub-commands, with a name,+-- description, a set of flags. Commands can be associated with actions and+-- run. It handles some common stuff automatically, like the @--help@ and+-- command line completion flags. It is designed to allow other tools make+-- derived commands. This feature is used heavily in @cabal-install@.+module Distribution.Simple.Command+  ( -- * Command interface+    CommandUI (..)+  , commandShowOptions+  , CommandParse (..)+  , commandParseArgs+  , getNormalCommandDescriptions+  , helpCommandUI++    -- ** Constructing commands+  , ShowOrParseArgs (..)+  , usageDefault+  , usageAlternatives+  , mkCommandUI+  , hiddenCommand++    -- ** Associating actions with commands+  , Command+  , commandAddAction+  , noExtraFlags++    -- ** Building lists of commands+  , CommandType (..)+  , CommandSpec (..)+  , commandFromSpec++    -- ** Running commands+  , commandsRun+  , commandsRunWithFallback+  , defaultCommandFallback++    -- * Option Fields+  , OptionField (..)+  , Name++    -- ** Constructing Option Fields+  , option+  , multiOption++    -- ** Liftings & Projections+  , liftOption+  , liftOptionL++    -- * 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 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++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 Description = String++-- | We usually have a data type for storing configuration values, where+--   every field stores a configuration option, and the user sets+--   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]+  }++-- | 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))+      (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)++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]++-- | Long command line option strings+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.+--+-- 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 n get set args = OptionField n [arg get set | arg <- args]++type MkOptDescr get set a =+  SFlags+  -> LFlags+  -> Description+  -> get+  -> set+  -> OptDescr a++-- | Create a string-valued command line interface.+-- Usually called in the context of 'option' or 'multiOption'.+--+-- 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)++-- | Create a string-valued command line interface with a default value.+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' ad 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' ad mkflag showflag =+  optArg ad (succeedReadE (mkflag . Just)) ("", mkflag Nothing) showflag++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++noArg :: Eq b => b -> MkOptDescr (a -> b) (b -> a -> a) a+noArg flag sf lf d = choiceOpt [(flag, (sf, lf), d)] sf lf d++boolOpt+  :: (b -> Maybe Bool)+  -> (Bool -> b)+  -> SFlags+  -> SFlags+  -> MkOptDescr (a -> b) (b -> a -> a) a+boolOpt g s sfT sfF _sf _lf@(n : _) d get set =+  BoolOpt d (sfT, ["enable-" ++ n]) (sfF, ["disable-" ++ n]) (set . s) (g . get)+boolOpt _ _ _ _ _ _ _ _ _ =+  error+    "Distribution.Simple.Setup.boolOpt: unreachable"++boolOpt'+  :: (b -> Maybe Bool)+  -> (Bool -> b)+  -> OptFlags+  -> OptFlags+  -> MkOptDescr (a -> b) (b -> a -> a) a+boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set . s) (g . get)++-- | create a Choice option+choiceOpt+  :: Eq b+  => [(b, OptFlags, Description)]+  -> MkOptDescr (a -> b) (b -> a -> a) a+choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts+  where+    alts = [(d, flags, set alt, (== alt) . get) | (alt, flags, d) <- aa_ff]++-- | 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 _sf _lf d get =+  choiceOpt+    [ (x, (sf, [map toLower $ show x]), d')+    | (x, sf) <- sflags'+    , let d' = d ++ show x+    ]+    _sf+    _lf+    d+    get+  where+    sflags' = foldl f [] [firstOne ..]+    f prev x =+      let prevflags = concatMap snd prev+       in prev+            ++ take+              1+              [ (x, [toLower sf])+              | sf <- show x+              , isAlpha sf+              , toLower sf `notElem` prevflags+              ]+    firstOne = minBound `asTypeOf` get undefined++commandGetOpts+  :: ShowOrParseArgs+  -> CommandUI flags+  -> [GetOpt.OptDescr (flags -> flags)]+commandGetOpts showOrParse command =+  concatMap viewAsGetOpt (commandOptions command showOrParse)++viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a -> a)]+viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa+  where+    optDescrToGetOpt (ReqArg d (cs, ss) arg_desc set _) =+      [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d]+    optDescrToGetOpt (OptArg d (cs, ss) arg_desc set (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)+      ]++getCurrentChoice :: OptDescr a -> a -> [String]+getCurrentChoice (ChoiceOpt alts) 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}++-- | @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 (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')+liftOptDescr get' set' (BoolOpt d ffT ffF set 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+    ]+  where+    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"++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+      commandGetOpts ShowArgs command+  where+    listOption (GetOpt.Option shortNames 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++-- | Default "usage" documentation text for commands.+usageDefault :: String -> String -> String+usageDefault name pname =+  "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+    ]++-- | 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+    }++-- | Common flags that apply to every command+data CommonFlag = HelpFlag | ListOptionsFlag++commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag]+commonFlags showOrParseArgs = case showOrParseArgs of+  ShowArgs -> [help]+  ParseArgs -> [help, list]+  where+    help =+      GetOpt.Option+        helpShortFlags+        ["help"]+        (GetOpt.NoArg HelpFlag)+        "Show this help text"+    helpShortFlags = case showOrParseArgs of+      ShowArgs -> ['h']+      ParseArgs -> ['h', '?']+    list =+      GetOpt.Option+        []+        ["list-options"]+        (GetOpt.NoArg ListOptionsFlag)+        "Print a list of command line flags"++addCommonFlags+  :: ShowOrParseArgs+  -> [GetOpt.OptDescr a]+  -> [GetOpt.OptDescr (Either CommonFlag a)]+addCommonFlags showOrParseArgs options =+  map (fmap Left) (commonFlags showOrParseArgs)+    ++ map (fmap Right) options++-- | Parse a bunch of command line arguments+commandParseArgs+  :: CommandUI flags+  -> Bool+  -- ^ Is the command a global or subcommand?+  -> [String]+  -> CommandParse (flags -> flags, [String])+commandParseArgs command global args =+  let options =+        addCommonFlags ParseArgs $+          commandGetOpts ParseArgs command+      order+        | global = GetOpt.RequireOrder+        | otherwise = GetOpt.Permute+   in case GetOpt.getOpt' order options args of+        (flags, _, _, _)+          | any listFlag flags -> CommandList (commandListOptions command)+          | any helpFlag flags -> CommandHelp (commandHelp command)+          where+            listFlag (Left ListOptionsFlag) = True; listFlag _ = False+            helpFlag (Left HelpFlag) = True; helpFlag _ = False+        (flags, opts, opts', [])+          | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts')+          | otherwise -> CommandErrors (unrecognised opts')+        (_, _, _, errs) -> CommandErrors errs+  where+    -- Note: It is crucial to use reverse function composition here or to+    -- reverse the flags here as we want to process the flags left to right+    -- but data flow in function composition is right to left.+    accum flags = foldr (flip (.)) id [f | Right f <- flags]+    unrecognised opts =+      [ "unrecognized "+        ++ "'"+        ++ (commandName command)+        ++ "'"+        ++ " option `"+        ++ opt+        ++ "'\n"+      | opt <- opts+      ]+    -- For unrecognised global flags we put them in the position just after+    -- the command, if there is one. This gives us a chance to parse them+    -- as sub-command rather than global flags.+    mix [] ys = ys+    mix (x : xs) ys = x : ys ++ xs++data CommandParse flags+  = CommandHelp (String -> String)+  | CommandList [String]+  | CommandErrors [String]+  | CommandReadyToGo flags+instance Functor CommandParse where+  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++-- | 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 synopsis f _cmdType) =+  Command name synopsis f HiddenCommand++commandAddAction+  :: CommandUI flags+  -> (flags -> [String] -> action)+  -> Command action+commandAddAction command action =+  Command+    (commandName command)+    (commandSynopsis command)+    (fmap (uncurry applyDefaultArgs) . commandParseArgs command False)+    NormalCommand+  where+    applyDefaultArgs mkflags args =+      let flags = mkflags (commandDefaultFlags command)+       in action flags args++-- 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]+  -> IO (CommandParse (a, CommandParse action))+commandsRun globalCommand commands args =+  commandsRunWithFallback globalCommand commands defaultCommandFallback args++defaultCommandFallback+  :: [Command action]+  -> String+  -> [String]+  -> IO (CommandParse action)+defaultCommandFallback commands' name _cmdArgs = pure $ badCommand commands' name++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+        flags = mkflags (commandDefaultFlags globalCommand)+  where+    lookupCommand cname =+      [ cmd | cmd@(Command cname' _ _ _) <- commands', cname' == cname+      ]++    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 flags cmdArgs =+      case commandParseArgs helpCommandUI True cmdArgs of+        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 -> 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)+  where+    (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 bnds [(ij, dist ij) | ij <- Array.range bnds]+    bnds = ((0, 0), (m, n))++    dist (0, j) = j+    dist (i, 0) = i+    dist (i, j) =+      minimum+        [ table Array.! (i - 1, j) + 1+        , table Array.! (i, j - 1) + 1+        , if x Array.! i == y Array.! j+            then table Array.! (i - 1, j - 1)+            else 1 + table Array.! (i - 1, j - 1)+        ]++-- | 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+--      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+  ]++helpCommandUI :: CommandUI ()+helpCommandUI =+  ( mkCommandUI+      "help"+      "Help about commands."+      ["[FLAGS]", "COMMAND [FLAGS]"]+      ()+      (const [])+  )+    { commandNotes = Just $ \pname ->+        "Examples:\n"+          ++ "  "+          ++ pname+          ++ " help help\n"+          ++ "    Oh, apparently you already know this.\n"+    }++-- | 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+-- top level of the program. That list can then be used for generation of manual page+-- as well as for executing the selected command.+data CommandSpec action+  = forall flags. CommandSpec (CommandUI flags) (CommandUI flags -> Command action) CommandType++commandFromSpec :: CommandSpec a -> Command a+commandFromSpec (CommandSpec ui action _) = action ui
+ src/Distribution/Simple/Compiler.hs view
@@ -0,0 +1,607 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Compiler+-- Copyright   :  Isaac Jones 2003-2004+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This should be a much more sophisticated abstraction than it is. Currently+-- it's just a bit of data about the compiler, like its flavour and name and+-- version. The reason it's just data is because currently it has to be in+-- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The+-- only interesting bit of info it contains is a mapping between language+-- extensions and compiler command line flags. This module also defines a+-- 'PackageDB' type which is used to refer to package databases. Most compilers+-- only know about a single global package collection but GHC has a global and+-- per-user one and it lets you create arbitrary other package databases. We do+-- not yet fully support this latter feature.+module Distribution.Simple.Compiler+  ( -- * Haskell implementations+      module Distribution.Compiler+  , Compiler (..)+  , showCompilerId+  , showCompilerIdWithAbi+  , compilerFlavor+  , compilerVersion+  , compilerCompatFlavor+  , compilerCompatVersion+  , compilerInfo++    -- * Support for package databases+  , PackageDB+  , PackageDBStack+  , PackageDBCWD+  , PackageDBStackCWD+  , PackageDBX (..)+  , PackageDBStackX+  , PackageDBS+  , PackageDBStackS+  , registrationPackageDB+  , absolutePackageDBPaths+  , absolutePackageDBPath+  , interpretPackageDB+  , interpretPackageDBStack+  , coercePackageDB+  , coercePackageDBStack++    -- * Support for optimisation levels+  , OptimisationLevel (..)+  , flagToOptimisationLevel++    -- * Support for debug info levels+  , DebugInfoLevel (..)+  , flagToDebugInfoLevel++    -- * Support for language extensions+  , CompilerFlag+  , languageToFlags+  , unsupportedLanguages+  , extensionsToFlags+  , unsupportedExtensions+  , parmakeSupported+  , reexportedModulesSupported+  , renamingPackageFlagsSupported+  , unifiedIPIDRequired+  , packageKeySupported+  , unitIdSupported+  , coverageSupported+  , profilingSupported+  , profilingDynamicSupported+  , profilingDynamicSupportedOrUnknown+  , profilingVanillaSupported+  , profilingVanillaSupportedOrUnknown+  , dynamicSupported+  , backpackSupported+  , arResponseFilesSupported+  , arDashLSupported+  , libraryDynDirSupported+  , libraryVisibilitySupported+  , jsemSupported+  , reexportedAsSupported++    -- * Support for profiling detail levels+  , ProfDetailLevel (..)+  , knownProfDetailLevels+  , flagToProfDetailLevel+  , showProfDetailLevel+  ) where++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 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, Show, Read)++instance Binary Compiler+instance Structured Compiler++showCompilerId :: Compiler -> String+showCompilerId = prettyShow . compilerId++showCompilerIdWithAbi :: Compiler -> String+showCompilerIdWithAbi comp =+  prettyShow (compilerId comp)+    ++ case compilerAbiTag comp of+      NoAbiTag -> []+      AbiTag xs -> '-' : xs++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]++-- | Is this compiler compatible with the compiler flavour we're interested in,+-- and if so what version does it claim to be compatible with.+--+-- For example this checks if the compiler is actually GHC-7.x or is another+-- compiler that claims to be compatible with some GHC-7.x version.+--+-- > 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]++compilerInfo :: Compiler -> CompilerInfo+compilerInfo c =+  CompilerInfo+    (compilerId c)+    (compilerAbiTag c)+    (Just . compilerCompat $ c)+    (Just . map fst . compilerLanguages $ c)+    (Just . map fst . compilerExtensions $ c)++-- ------------------------------------------------------------++-- * Package databases++-- ------------------------------------------------------------++-- | Some compilers have a notion of a database of available packages.+--  For some there is just one global db of packages, other compilers+--  support a per-user or an arbitrary db specified at some location in+--  the file system. This can be used to build isolated environments of+--  packages, for example to build a collection of related packages+--  without installing them globally.+--+--  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 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+-- typical stacks include:+--+-- > [GlobalPackageDB]+-- > [GlobalPackageDB, UserPackageDB]+-- > [GlobalPackageDB, SpecificPackageDB "package.conf.inplace"]+--+-- Note that the 'GlobalPackageDB' is invariably at the bottom since it+-- contains the rts, base and other special compiler-specific packages.+--+-- We are not restricted to using just the above combinations. In particular+-- 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 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 :: PackageDBStackX from -> PackageDBX from+registrationPackageDB dbs = case safeLast dbs of+  Nothing -> error "internal error: empty package db set"+  Just p -> p++-- | Make package paths absolute+absolutePackageDBPaths+  :: 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'++interpretPackageDB :: Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageDBCWD+interpretPackageDB _ GlobalPackageDB = GlobalPackageDB+interpretPackageDB _ UserPackageDB = UserPackageDB+interpretPackageDB mbWorkDir (SpecificPackageDB db) =+  SpecificPackageDB (interpretSymbolicPath mbWorkDir db)++interpretPackageDBStack :: Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDBStack -> PackageDBStackCWD+interpretPackageDBStack mbWorkDir = map (interpretPackageDB mbWorkDir)++-- | Transform a package db using a FilePath into one using symbolic paths.+coercePackageDB :: PackageDBCWD -> PackageDBX (SymbolicPath CWD (Dir PkgDB))+coercePackageDB GlobalPackageDB = GlobalPackageDB+coercePackageDB UserPackageDB = UserPackageDB+coercePackageDB (SpecificPackageDB db) = SpecificPackageDB (makeSymbolicPath db)++coercePackageDBStack+  :: [PackageDBCWD]+  -> [PackageDBX (SymbolicPath CWD (Dir PkgDB))]+coercePackageDBStack = map coercePackageDB++-- ------------------------------------------------------------++-- * Optimisation levels++-- ------------------------------------------------------------++-- | 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)++instance Binary OptimisationLevel+instance Structured OptimisationLevel++flagToOptimisationLevel :: Maybe String -> OptimisationLevel+flagToOptimisationLevel Nothing = NormalOptimisation+flagToOptimisationLevel (Just s) = case reads s of+  [(i, "")]+    | i >= fromEnum (minBound :: OptimisationLevel)+        && i <= fromEnum (maxBound :: OptimisationLevel) ->+        toEnum i+    | otherwise ->+        error $+          "Bad optimisation level: "+            ++ show i+            ++ ". Valid values are 0..2"+  _ -> 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)++instance Binary DebugInfoLevel+instance Structured DebugInfoLevel++flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel+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++-- ------------------------------------------------------------++-- * Languages and Extensions++-- ------------------------------------------------------------++unsupportedLanguages :: Compiler -> [Language] -> [Language]+unsupportedLanguages comp langs =+  [ 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])++languageToFlag :: Compiler -> Language -> Maybe CompilerFlag+languageToFlag comp ext = lookup ext (compilerLanguages comp)++-- | 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)+  ]++type CompilerFlag = String++-- | 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)++-- | Looks up the flag for a given extension, for a given compiler.+-- Ignores the subtlety of extensions which lack associated flags.+extensionToFlag :: Compiler -> Extension -> Maybe CompilerFlag+extensionToFlag comp ext = join (extensionToFlag' comp ext)++-- | Looks up the flag for a given extension, for a given compiler.+-- However, the extension may be valid for the compiler but not have a flag.+-- For example, NondecreasingIndentation is enabled by default on GHC 7.0.4,+-- hence it is considered a supported extension but not an accepted flag.+--+-- The outer layer of Maybe indicates whether the extensions is supported, while+-- the inner layer indicates whether it has a flag.+-- When building strings, it is often more convenient to use 'extensionToFlag',+-- which ignores the difference.+extensionToFlag' :: Compiler -> Extension -> Maybe (Maybe CompilerFlag)+extensionToFlag' comp ext = lookup ext (compilerExtensions comp)++-- | Does this compiler support parallel --make mode?+parmakeSupported :: Compiler -> Bool+parmakeSupported = ghcSupported "Support parallel --make"++-- | Does this compiler support reexported-modules?+reexportedModulesSupported :: Compiler -> Bool+reexportedModulesSupported = ghcSupported "Support reexported-modules"++-- | Does this compiler support thinning/renaming on package flags?+renamingPackageFlagsSupported :: Compiler -> Bool+renamingPackageFlagsSupported =+  ghcSupported+    "Support thinning and renaming package flags"++-- | Does this compiler have unified IPIDs (so no package keys)+unifiedIPIDRequired :: Compiler -> Bool+unifiedIPIDRequired = ghcSupported "Requires unified installed package IDs"++-- | Does this compiler support package keys?+packageKeySupported :: Compiler -> Bool+packageKeySupported = ghcSupported "Uses package keys"++-- | Does this compiler support unit IDs?+unitIdSupported :: Compiler -> Bool+unitIdSupported = ghcSupported "Uses unit IDs"++-- | Does this compiler support Backpack?+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++-- | 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+    GHCJS -> True+    _ -> False++-- | Does this compiler support profiling?+profilingSupported :: Compiler -> Bool+profilingSupported comp =+  case compilerFlavor comp of+    GHC -> True+    GHCJS -> True+    _ -> False++-- | Returns Just if we can certainly determine whether a way is supported+-- if we don't know, return Nothing+waySupported :: String -> Compiler -> Maybe Bool+waySupported way comp =+  case compilerFlavor comp of+    GHC ->+      -- Information about compiler ways is only accurately reported after+      -- 9.10.1. Which is useful as this is before profiling dynamic support+      -- was introduced. (See GHC #24881)+      if compilerVersion comp >= mkVersion [9, 10, 1]+        then case Map.lookup "RTS ways" (compilerProperties comp) of+          Just ways -> Just (way `elem` words ways)+          Nothing -> Just False+        else Nothing+    _ -> Nothing++-- | Either profiling is definitely supported or we don't know (so assume+-- it is)+profilingVanillaSupportedOrUnknown :: Compiler -> Bool+profilingVanillaSupportedOrUnknown comp = profilingVanillaSupported comp `elem` [Just True, Nothing]++-- | Is the compiler distributed with profiling libraries+profilingVanillaSupported :: Compiler -> Maybe Bool+profilingVanillaSupported comp = waySupported "p" comp++-- | Is the compiler distributed with profiling dynamic libraries+profilingDynamicSupported :: Compiler -> Maybe Bool+profilingDynamicSupported comp+  | GHC <- compilerFlavor comp+  , -- Certainly not before 9.11, as prof+dyn was not implemented yet.+    compilerVersion comp <= mkVersion [9, 11, 0] =+      Just False+  | otherwise =+      waySupported "p_dyn" comp++-- | Either profiling dynamic is definitely supported or we don't know (so assume+-- it is)+profilingDynamicSupportedOrUnknown :: Compiler -> Bool+profilingDynamicSupportedOrUnknown comp =+  profilingDynamicSupported comp `elem` [Just True, Nothing]++-- | Is the compiler distributed with dynamic libraries+dynamicSupported :: Compiler -> Maybe Bool+dynamicSupported comp = waySupported "dyn" comp++-- | Does 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++-- | Utility function for GHC only features+ghcSupported :: String -> Compiler -> Bool+ghcSupported key comp =+  case compilerFlavor comp of+    GHC -> checkProp+    GHCJS -> checkProp+    _ -> 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+-- programs so the system can account costs to different functions. There are+-- different levels of detail that can be used for this accounting.+-- For compilers that do not support this notion or the particular detail+-- levels, this is either ignored or just capped to some similar level+-- they do support.+data ProfDetailLevel+  = ProfDetailNone+  | ProfDetailDefault+  | ProfDetailExportedFunctions+  | ProfDetailToplevelFunctions+  | ProfDetailAllFunctions+  | ProfDetailTopLate+  | ProfDetailOther String+  deriving (Eq, Generic, Read, Show)++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++knownProfDetailLevels :: [(String, [String], ProfDetailLevel)]+knownProfDetailLevels =+  [ ("default", [], ProfDetailDefault)+  , ("none", [], ProfDetailNone)+  , ("exported-functions", ["exported"], ProfDetailExportedFunctions)+  , ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions)+  , ("all-functions", ["all"], ProfDetailAllFunctions)+  , ("late-toplevel", ["late"], ProfDetailTopLate)+  ]++showProfDetailLevel :: ProfDetailLevel -> String+showProfDetailLevel dl = case dl of+  ProfDetailNone -> "none"+  ProfDetailDefault -> "default"+  ProfDetailExportedFunctions -> "exported-functions"+  ProfDetailToplevelFunctions -> "toplevel-functions"+  ProfDetailAllFunctions -> "all-functions"+  ProfDetailTopLate -> "late-toplevel"+  ProfDetailOther other -> other
+ src/Distribution/Simple/Configure.hs view
@@ -0,0 +1,2981 @@+{-# 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++    unsupported :: [String] -> Maybe String+    unsupported = Just . concat
+ 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
@@ -0,0 +1,125 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Flag+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Defines the 'Flag' type and it's 'Monoid' instance,  see+-- <http://www.haskell.org/pipermail/cabal-devel/2007-December/001509.html>+-- for an explanation.+--+-- Split off from "Distribution.Simple.Setup" to break import cycles.+module Distribution.Simple.Flag+  ( Flag+  , pattern Flag+  , pattern NoFlag+  , allFlags+  , toFlag+  , fromFlag+  , fromFlagOrDefault+  , flagElim+  , flagToMaybe+  , flagToList+  , maybeToFlag+  , mergeListFlag+  , BooleanFlag (..)+  ) where++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+--+--   gives us all the values ["foo", "bar"]+--+-- 2. singular value flags, eg:+--+--   > --enable-foo --disable-foo+--+--   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.+--+-- Isomorphic to 'Maybe' a.+type Flag = Last++pattern Flag :: a -> Last a+pattern Flag a = Last (Just a)++pattern NoFlag :: Last a+pattern NoFlag = Last Nothing++{-# 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"++-- | Extracts a value from a 'Flag', and returns the default value on 'NoFlag'.+fromFlagOrDefault :: a -> Flag a -> a+fromFlagOrDefault def = fromMaybe def . getLast++-- | Converts a 'Flag' value to a 'Maybe' value.+flagToMaybe :: Flag a -> Maybe a+flagToMaybe = getLast++-- | Pushes a function through a 'Flag' value, and returns a default+-- if the 'Flag' value is 'NoFlag'.+--+-- @since 3.4.0.0+flagElim :: b -> (a -> b) -> Flag a -> b+flagElim n f = maybe n f . getLast++-- | Converts a 'Flag' value to a list.+flagToList :: Flag a -> [a]+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++-- | Converts a 'Maybe' value to a 'Flag' value.+maybeToFlag :: Maybe a -> Flag a+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++instance BooleanFlag Bool where+  asBool = id
+ src/Distribution/Simple/GHC.hs view
@@ -0,0 +1,1166 @@+{-# 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
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Distribution.Simple.GHC.EnvironmentParser (parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc (..)) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Simple.Compiler+import Distribution.Simple.GHC.Internal+  ( GhcEnvironmentFileEntry (..)+  )+import Distribution.Types.UnitId+  ( mkUnitId+  )++import qualified Text.Parsec as P+import Text.Parsec.String+  ( Parser+  , parseFromFile+  )++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)++instance Exception ParseErrorExc++parseGhcEnvironmentFile :: Parser [GhcEnvironmentFileEntry FilePath]+parseGhcEnvironmentFile = parseEnvironmentFileLine `P.sepEndBy` P.endOfLine <* P.eof++readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry FilePath]+readGhcEnvironmentFile path =+  either (throwIO . ParseErrorExc) return+    =<< parseFromFile parseGhcEnvironmentFile path
+ src/Distribution/Simple/GHC/ImplInfo.hs view
@@ -0,0 +1,135 @@+-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.GHC.ImplInfo+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- 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++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.+data GhcImplInfo = GhcImplInfo+  { 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)+    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+        )++ghcVersionImplInfo :: Version -> GhcImplInfo+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+    , 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
@@ -0,0 +1,864 @@+{-# 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
@@ -0,0 +1,2121 @@+{-# 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+  , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"]+  )+  where+    script = exe <.> "jsexe" </> "all" <.> "js"+    ghcjsProg = fromMaybe (error "GHCJS.runCmd: no ghcjs program") $ lookupProgram ghcjsProgram progdb
+ src/Distribution/Simple/Glob.hs view
@@ -0,0 +1,522 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Glob+-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004+-- License     :  BSD3+--                portions Copyright (c) 2007, Galois Inc.+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Simple file globbing.+module Distribution.Simple.Glob+  ( -- * Globs+    Glob++    -- * Matching on globs+  , GlobResult (..)+  , globMatches+  , fileGlobMatches+  , matchGlob+  , matchGlobPieces+  , matchDirFileGlob+  , matchDirFileGlobWithDie+  , runDirFileGlob++    -- * 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 Control.Monad (mapM)+import Data.List (stripPrefix)+import System.Directory+import System.FilePath hiding ((<.>), (</>))++-------------------------------------------------------------------------------++-- * Matching++--------------------------------------------------------------------------------++-- | Match a 'Glob' against the file system, starting from a+-- given root directory. The results are all relative to the given root.+--+-- @since 3.12.0.0+matchGlob :: FilePath -> Glob -> IO [FilePath]+matchGlob root glob =+  -- For this function, which is the general globbing one (doesn't care about+  -- cabal spec, used e.g. for monitoring), we consider all matches.+  mapMaybe+    ( \case+        GlobMatch a -> Just a+        GlobWarnMultiDot a -> Just a+        GlobMatchesDirectory a -> Just a+        GlobMissingDirectory{} -> Nothing+    )+    <$> runDirFileGlob 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]++-- | 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++-- | 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]++          let errors :: [String]+              errors =+                [ "filepath wildcard '"+                  ++ rawFilePath+                  ++ "' refers to the directory"+                  ++ " '"+                  ++ missingDir+                  ++ "', which does not exist or is not a directory."+                | missingDir <- missingDirectories+                ]+                  ++ [ "filepath wildcard '" ++ rawFilePath ++ "' does not match any files."+                     | null matches && null directoryMatches+                     -- we don't error out on directory matches, simply warn about them and ignore.+                     ]++              warns :: [String]+              warns =+                [ "Ignoring directory '" ++ path ++ "'" ++ " listed in a Cabal package field which should only include files (not directories)."+                | path <- directoryMatches+                ]++          if null errors+            then do+              unless (null warns) $+                warn verbosity $+                  unlines warns+              return $ map unsafeMakeSymbolicPath matches+            else rip verbosity $ MatchDirFileGlobErrors errors++-------------------------------------------------------------------------------++-- * Parsing & printing++--------------------------------------------------------------------------------+-- Filepaths with globs may be parsed in the special context is globbing in+-- cabal package fields, such as `data-files`. In that case, we restrict the+-- globbing syntax to that supported by the cabal spec version in use.+-- Otherwise, we parse the globs to the extent of our globbing features+-- (wildcards `*`, unions `{a,b,c}`, and directory-recursive wildcards `**`).++-- ** Parsing globs in a cabal package++parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob+parseFileGlob version filepath = case reverse (splitDirectories filepath) of+  [] ->+    Left EmptyGlob+  (filename : "**" : segments)+    | allowGlobStar -> do+        finalSegment <- case splitExtensions filename of+          ("*", ext)+            | '*' `elem` ext -> Left StarInExtension+            | null ext -> Left NoExtensionOnStar+            | otherwise -> Right (GlobDirRecursive [WildCard, Literal ext])+          _+            | allowLiteralFilenameGlobStar ->+                Right (GlobDirRecursive [Literal filename])+            | otherwise ->+                Left LiteralFileNameGlobStar++        foldM addStem finalSegment segments+    | otherwise -> Left VersionDoesNotSupportGlobStar+  (filename : segments) -> do+    pat <- case splitExtensions filename of+      ("*", ext)+        | not allowGlob -> Left VersionDoesNotSupportGlob+        | '*' `elem` ext -> Left StarInExtension+        | null ext -> Left NoExtensionOnStar+        | otherwise -> Right (GlobFile [WildCard, Literal ext])+      (_, ext)+        | '*' `elem` ext -> Left StarInExtension+        | '*' `elem` filename -> Left StarInFileName+        | otherwise -> Right (GlobFile [Literal filename])++    foldM addStem pat segments+  where+    addStem pat seg+      | '*' `elem` seg = Left StarInDirectory+      | otherwise = Right (GlobDir [Literal seg] pat)+    allowGlob = version >= CabalSpecV1_6+    allowGlobStar = version >= CabalSpecV2_4+    allowLiteralFilenameGlobStar = version >= CabalSpecV3_8++enableMultidot :: CabalSpecVersion -> Bool+enableMultidot version+  | version >= CabalSpecV2_4 = True+  | otherwise = False++--------------------------------------------------------------------------------+-- Parse and printing utils+--------------------------------------------------------------------------------++-- ** Cabal package globbing errors++data GlobSyntaxError+  = StarInDirectory+  | StarInFileName+  | StarInExtension+  | NoExtensionOnStar+  | EmptyGlob+  | LiteralFileNameGlobStar+  | VersionDoesNotSupportGlobStar+  | VersionDoesNotSupportGlob+  deriving (Eq, Show)++explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String+explainGlobSyntaxError filepath StarInDirectory =+  "invalid file glob '"+    ++ filepath+    ++ "'. A wildcard '**' is only allowed as the final parent"+    ++ " directory. Stars must not otherwise appear in the parent"+    ++ " directories."+explainGlobSyntaxError filepath StarInExtension =+  "invalid file glob '"+    ++ filepath+    ++ "'. Wildcards '*' are only allowed as the"+    ++ " file's base name, not in the file extension."+explainGlobSyntaxError filepath StarInFileName =+  "invalid file glob '"+    ++ filepath+    ++ "'. Wildcards '*' may only totally replace the"+    ++ " file's base name, not only parts of it."+explainGlobSyntaxError filepath NoExtensionOnStar =+  "invalid file glob '"+    ++ filepath+    ++ "'. If a wildcard '*' is used it must be with an file extension."+explainGlobSyntaxError filepath LiteralFileNameGlobStar =+  "invalid file glob '"+    ++ filepath+    ++ "'. Prior to 'cabal-version: 3.8'"+    ++ " if a wildcard '**' is used as a parent directory, the"+    ++ " file's base name must be a wildcard '*'."+explainGlobSyntaxError _ EmptyGlob =+  "invalid file glob. A glob cannot be the empty string."+explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar =+  "invalid file glob '"+    ++ filepath+    ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'"+    ++ " or greater. Alternatively, for compatibility with earlier Cabal"+    ++ " versions, list the included directories explicitly."+explainGlobSyntaxError filepath VersionDoesNotSupportGlob =+  "invalid file glob '"+    ++ filepath+    ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. "+    ++ "Alternatively if you require compatibility with earlier Cabal "+    ++ "versions then list all the files explicitly."++-- Note throughout that we use splitDirectories, not splitPath. On+-- Posix, this makes no difference, but, because Windows accepts both+-- slash and backslash as its path separators, if we left in the+-- separators from the glob we might not end up properly normalised.++data GlobResult a+  = -- | The glob matched the value supplied.+    GlobMatch a+  | -- | The glob did not match the value supplied because the+    --   cabal-version is too low and the extensions on the file did+    --   not precisely match the glob's extensions, but rather the+    --   glob was a proper suffix of the file's extensions; i.e., if+    --   not for the low cabal-version, it would have matched.+    GlobWarnMultiDot a+  | -- | The glob couldn't match because the directory named doesn't+    --   exist. The directory will be as it appears in the glob (i.e.,+    --   relative to the directory passed to 'matchDirFileGlob', and,+    --   for 'data-files', relative to 'data-dir').+    GlobMissingDirectory a+  | -- | The glob matched a directory when we were looking for files only.+    -- It didn't match a file!+    --+    -- @since 3.12.0.0+    GlobMatchesDirectory a+  deriving (Show, Eq, Ord, Functor)++-- | Match files against a pre-parsed glob, starting in a directory.+--+-- The 'Version' argument must be the spec version of the package+-- description being processed, as globs behave slightly differently+-- in different spec versions.+--+-- The 'FilePath' argument is the directory that the glob is relative+-- to. It must be a valid directory (and hence it can't be the empty+-- string). The returned values will not include this prefix.+runDirFileGlob+  :: Verbosity+  -> Maybe CabalSpecVersion+  -- ^ If the glob we are running should care about the cabal spec, and warnings such as 'GlobWarnMultiDot', then this should be the version.+  -- If you want to run a glob but don't care about any of the cabal-spec restrictions on globs, use 'Nothing'!+  -> FilePath+  -> Glob+  -> IO [GlobResult FilePath]+runDirFileGlob verbosity mspec rawRoot pat = do+  -- The default data-dir is null. Our callers -should- be+  -- converting that to '.' themselves, but it's a certainty that+  -- some future call-site will forget and trigger a really+  -- hard-to-debug failure if we don't check for that here.+  when (null rawRoot) $+    warn verbosity $+      "Null dir passed to runDirFileGlob; interpreting it "+        ++ "as '.'. This is probably an internal error."+  let root = if null rawRoot then "." else rawRoot+  -- This function might be called from the project root with dir as+  -- ".". Walking the tree starting there involves going into .git/+  -- and dist-newstyle/, which is a lot of work for no reward, so+  -- extract the constant prefix from the pattern and start walking+  -- there, and only walk as much as we need to: recursively if **,+  -- the whole directory if *, and just the specific file if it's a+  -- literal.+  let+    (prefixSegments, pathOrVariablePattern) = splitConstantPrefix pat+    joinedPrefix = joinPath prefixSegments++    -- 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 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++        step (GlobDir [Literal seg] pat') = Right (seg, pat')+        step pat' = Left pat'++        unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r)+        unfoldr' f a = case f a of+          Left r -> ([], r)+          Right (b, a') -> case unfoldr' f a' of+            (bs, r) -> (b : bs, r)++-- | Is the root of this relative glob path a directory-recursive wildcard, e.g. @**/*.txt@ ?+isRecursiveInRoot :: Glob -> Bool+isRecursiveInRoot (GlobDirRecursive _) = True+isRecursiveInRoot _ = False++-- | Check how the string matches the glob under this cabal version+checkNameMatches :: CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ())+checkNameMatches spec glob candidate+  -- Check if glob matches in its general form+  | matchGlobPieces glob candidate =+      -- if multidot is supported, then this is a clean match+      if enableMultidot spec+        then pure (GlobMatch ())+        else -- if not, issue a warning saying multidot is needed for the match++          let (_, candidateExts) = splitExtensions $ takeFileName candidate+              extractExts :: GlobPieces -> Maybe String+              extractExts [] = Nothing+              extractExts [Literal lit]+                -- Any literal terminating a glob, and which does have an extension,+                -- returns that extension. Otherwise, recurse until Nothing is returned.+                | let ext = takeExtensions lit+                , ext /= "" =+                    Just ext+              extractExts (_ : x) = extractExts x+           in case extractExts glob of+                Just exts+                  | exts == candidateExts ->+                      return (GlobMatch ())+                  | exts `isSuffixOf` candidateExts ->+                      return (GlobWarnMultiDot ())+                _ -> return (GlobMatch ())+  | otherwise = empty++-- | How/does the glob match the given filepath, according to the cabal version?+-- Since this is pure, we don't make a distinction between matching on+-- directories or files (i.e. this function won't return 'GlobMatchesDirectory')+fileGlobMatches :: CabalSpecVersion -> Glob -> FilePath -> Maybe (GlobResult ())+fileGlobMatches version g path = go g (splitDirectories path)+  where+    go GlobDirTrailing [] = Just (GlobMatch ())+    go (GlobFile glob) [file] = checkNameMatches version glob file+    go (GlobDirRecursive glob) dirs+      | [] <- reverse dirs =+          Nothing -- @dir/**/x.txt@ should not match @dir/hello@+      | file : _ <- reverse dirs =+          checkNameMatches version glob file+    go (GlobDir glob globPath) (dir : dirs) = do+      _ <- checkNameMatches version glob dir -- we only care if dir segment matches+      go globPath dirs+    go _ _ = Nothing
+ src/Distribution/Simple/Glob/Internal.hs view
@@ -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
@@ -0,0 +1,1634 @@+{-# 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/Hpc.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Hpc+-- Copyright   :  Thomas Tuegel 2011+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- 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+  , HPCMarkupInfo (..)+  , markupPackage+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.ModuleName (ModuleName, main)+import Distribution.PackageDescription+  ( TestSuite (..)+  , testModules+  )+import qualified Distribution.PackageDescription as PD+import Distribution.Pretty+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.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 | ProfDyn+  deriving (Bounded, Enum, Eq, Read, Show)++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+  :: 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+  :: 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+  :: 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+  :: 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.+guessWay :: LocalBuildInfo -> Way+guessWay lbi+  | withProfExe lbi = Prof+  | withDynExe lbi = Dyn+  | otherwise = Vanilla++-- | 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 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` way) . coerceSymbolicPath) pathsToLibsArtifacts
+ src/Distribution/Simple/Install.hs view
@@ -0,0 +1,372 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Install+-- Copyright   :  Isaac Jones 2003-2004+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This is the entry point into installing a built package. Performs the+-- \"@.\/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+  , install_setupHooks+  , installFileGlob+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.CabalSpecVersion (CabalSpecVersion)++import Distribution.Types.ExecutableScope+import Distribution.Types.ForeignLib+import Distribution.Types.LocalBuildInfo+import Distribution.Types.PackageDescription+import Distribution.Types.TargetInfo+import Distribution.Types.UnqualComponentName++import Distribution.Package+import Distribution.PackageDescription+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+  , dieWithException+  , info+  , installDirectoryContents+  , installOrdinaryFile+  , isAbsoluteOnAnyPlatform+  , isInSearchPath+  , noticeNoWrap+  , warn+  )+import Distribution.Utils.Path++import Distribution.Compat.Graph (IsNode (..))+import Distribution.Simple.Errors+import qualified Distribution.Simple.GHC as GHC+import qualified Distribution.Simple.GHCJS as GHCJS+import Distribution.Simple.Setup.Common+import qualified Distribution.Simple.UHC as UHC++import System.Directory+  ( doesDirectoryExist+  , doesFileExist+  )+import System.FilePath+  ( takeDirectory+  , takeFileName+  )++import Distribution.Pretty+  ( prettyShow+  )+import Distribution.Verbosity++-- | Perform the \"@.\/setup install@\" and \"@.\/setup copy@\"+--  actions.  Move files into place based on the prefix argument.+--+--  This does NOT register libraries, you should call 'register'+--  to do that.+install+  :: PackageDescription+  -- ^ information from the .cabal file+  -> LocalBuildInfo+  -- ^ information from the configure step+  -> CopyFlags+  -- ^ flags sent to copy or install+  -> IO ()+install = install_setupHooks SetupHooks.noInstallHooks++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++    -- 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) $+          warn verbosity "No executables and no library found. Nothing to do."++-- | Copy package global files.+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+      } = 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 mbWorkDir pkg_descr $ makeSymbolicPath dataPref++  -- Install (package-global) Haddock files+  -- TODO: these should be done per-library+  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+      (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+      installOrdinaryFile+        verbosity+        (i lfile)+        (docPref </> takeFileName (getSymbolicPath lfile))++-- | Copy files associated with a component.+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 = interpretSymbolicPathLBI lbi $ 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)++  -- 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 = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi++  noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref)+  installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref++  case compilerFlavor (compiler lbi) of+    GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib+    GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib+    _ -> 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 = 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+  -> 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 = 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' = 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
@@ -0,0 +1,554 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.InstallDirs+-- Copyright   :  Isaac Jones 2003-2004+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This manages everything to do with where files get installed (though does+-- not get involved with actually doing any installation). It provides an+-- 'InstallDirs' type which is a set of directories for where to install+-- things. It also handles the fact that we use templates in these install+-- dirs. For example most install dirs are relative to some @$prefix@ and by+-- 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+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Compat.Environment (lookupEnv)+import Distribution.Compiler+import Distribution.Package+import Distribution.Pretty+import Distribution.Simple.InstallDirs.Internal+import Distribution.System++import System.Directory (getAppUserDataDirectory)+import System.FilePath+  ( dropDrive+  , isPathSeparator+  , pathSeparator+  , takeDirectory+  , (</>)+  )++#ifdef mingw32_HOST_OS+import qualified Prelude+import Foreign+import Foreign.C+#endif++-- ---------------------------------------------------------------------------+-- 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)++instance Binary dir => Binary (InstallDirs dir)+instance Structured dir => Structured (InstallDirs dir)++instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where+  mempty = gmempty+  mappend = (<>)++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+    }++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"+    }++-- | The installation directories in terms of 'PathTemplate's that contain+-- variables.+--+-- The defaults for most of the directories are relative to each other, in+-- particular they are all relative to a single prefix. This makes it+-- convenient for the user to override the default installation directory+-- by only having to specify --prefix=... rather than overriding each+-- individually. This is done by allowing $-style variables in the dirs.+-- These are expanded by textual substitution (see 'substPathTemplate').+--+-- A few of these installation directories are split into two components, the+-- dir and subdir. The full installation path is formed by combining the two+-- together with @\/@. The reason for this is compatibility with other Unix+-- build systems which also support @--libdir@ and @--datadir@. We would like+-- users to be able to configure @--libdir=\/usr\/lib64@ for example but+-- because by default we want to support installing multiple versions of+-- packages and building the same package for multiple compilers we append the+-- libsubdir to get: @\/usr\/lib64\/$libname\/$compiler@.+--+-- An additional complication is the need to support relocatable packages on+-- systems which support such things, like Windows.+type InstallDirTemplates = InstallDirs PathTemplate++-- ---------------------------------------------------------------------------+-- Default installation directories++defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates+defaultInstallDirs = defaultInstallDirs' False++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"+      }+defaultInstallDirs' False comp userInstall _hasLibs = do+  installPrefix <-+    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")+        Haiku -> return "/boot/system/non-packaged"+        _ -> return "/usr/local"+  installLibDir <-+    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"+            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++-- | Substitute the install dir templates into each other.+--+-- To prevent cyclic substitutions, only some variables are allowed in+-- particular dir templates. If out of scope vars are present, they are not+-- substituted for. Checking for any remaining unsubstituted vars can be done+-- as a subsequent operation.+--+-- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we+-- 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 env dirs = dirs'+  where+    dirs' =+      InstallDirs+        { -- So this specifies exactly which vars are allowed in each template+          prefix = subst prefix []+        , bindir = subst bindir [prefixVar]+        , libdir = subst libdir [prefixVar, bindirVar]+        , libsubdir = subst libsubdir []+        , dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar]+        , flibdir = subst flibdir [prefixVar, bindirVar, libdirVar]+        , libexecdir = subst libexecdir prefixBinLibVars+        , libexecsubdir = subst libexecsubdir []+        , includedir = subst includedir prefixBinLibVars+        , datadir = subst datadir prefixBinLibVars+        , datasubdir = subst datasubdir []+        , docdir = subst docdir prefixBinLibDataVars+        , mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar])+        , htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar])+        , haddockdir =+            subst+              haddockdir+              ( prefixBinLibDataVars+                  ++ [docdirVar, htmldirVar]+              )+        , sysconfdir = subst sysconfdir prefixBinLibVars+        }+    subst dir env' = substPathTemplate (env' ++ env) (dir dirs)++    prefixVar = (PrefixVar, prefix dirs')+    bindirVar = (BindirVar, bindir dirs')+    libdirVar = (LibdirVar, libdir dirs')+    libsubdirVar = (LibsubdirVar, libsubdir dirs')+    datadirVar = (DatadirVar, datadir dirs')+    datasubdirVar = (DatasubdirVar, datasubdir dirs')+    docdirVar = (DocdirVar, docdir dirs')+    htmldirVar = (HtmldirVar, htmldir dirs')+    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 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+  where+    env = initialPathTemplateEnv pkgId libname compilerId platform+    substPrefix pre root path+      | pre `isPrefixOf` path = root ++ drop (length pre) path+      | otherwise = path++-- | The location prefix for the /copy/ command.+data CopyDest+  = NoCopyDest+  | CopyTo FilePath+  | -- | 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 pkgId libname compilerId platform dirs =+  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.+      env+      dirs+        { prefix = PathTemplate [Variable PrefixVar]+        }+  where+    env = initialPathTemplateEnv pkgId libname compilerId platform++    -- If it starts with $prefix then it's relative and produce the relative+    -- 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 : rest) = Just rest+    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)++instance Binary PathTemplate+instance Structured PathTemplate++type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]++-- | Convert a 'FilePath' to a 'PathTemplate' including any template vars.+toPathTemplate :: FilePath -> 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++combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate+combinePathTemplate (PathTemplate t1) (PathTemplate t2) =+  PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2)++substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate+substPathTemplate environment (PathTemplate template) =+  PathTemplate (concatMap subst template)+  where+    subst component@(Ordinary _) = [component]+    subst component@(Variable variable) =+      case lookup variable environment of+        Just (PathTemplate components) -> components+        Nothing -> [component]++-- | The initial environment has all the static stuff but no paths+initialPathTemplateEnv+  :: PackageIdentifier+  -> UnitId+  -> CompilerInfo+  -> Platform+  -> PathTemplateEnv+initialPathTemplateEnv pkgId libname 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])+  ]++compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv+compilerTemplateEnv compiler =+  [ (CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)])+  ]++platformTemplateEnv :: Platform -> PathTemplateEnv+platformTemplateEnv (Platform arch os) =+  [ (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)])+  ]++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)+  ]++-- ---------------------------------------------------------------------------+-- Parsing and showing path templates:++-- The textual format is that of an ordinary Haskell String, eg+-- "$prefix/bin"+-- and this gets parsed to the internal representation as a sequence of path+-- spans which are either strings or variables, eg:+-- PathTemplate [Variable PrefixVar, Ordinary "/bin" ]++instance Show PathTemplate where+  show (PathTemplate template) = show (show template)++instance Read PathTemplate where+  readsPrec p s =+    [ (PathTemplate template, s')+    | (path, s') <- readsPrec p s+    , (template, "") <- reads path+    ]++-- ---------------------------------------------------------------------------+-- Internal utilities++{- FOURMOLU_DISABLE -}+getWindowsProgramFilesDir :: IO FilePath+getWindowsProgramFilesDir = do+#ifdef mingw32_HOST_OS+  m <- shGetFolderPath csidl_PROGRAM_FILES+#else+  let m = Nothing+#endif+  return (fromMaybe "C:\\Program Files" m)+{- FOURMOLU_ENABLE -}++#ifdef mingw32_HOST_OS+shGetFolderPath :: CInt -> IO (Maybe FilePath)+shGetFolderPath n =+  allocaArray long_path_size $ \pPath -> do+     r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath+     if (r /= 0)+        then return Nothing+        else do s <- peekCWString pPath; return (Just s)+  where+    long_path_size      = 1024 -- MAX_PATH is 260, this should be plenty++csidl_PROGRAM_FILES :: CInt+csidl_PROGRAM_FILES = 0x0026+-- csidl_PROGRAM_FILES_COMMON :: CInt+-- csidl_PROGRAM_FILES_COMMON = 0x002b++{- FOURMOLU_DISABLE -}+#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH)+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif++foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW"+            c_SHGetFolderPath :: Ptr ()+                              -> CInt+                              -> Ptr ()+                              -> CInt+                              -> CWString+                              -> Prelude.IO CInt+#endif+{- FOURMOLU_ENABLE -}
+ src/Distribution/Simple/InstallDirs/Internal.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Simple.InstallDirs.Internal+  ( PathComponent (..)+  , PathTemplateVariable (..)+  ) where++import Distribution.Compat.Prelude+import Prelude ()++data PathComponent+  = Ordinary FilePath+  | Variable PathTemplateVariable+  deriving (Eq, Ord, Generic)++instance Binary PathComponent+instance Structured PathComponent++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 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 ExecutableNameVar = "executablename"+  show TestSuiteNameVar = "test-suite"+  show TestSuiteResultVar = "result"+  show BenchmarkNameVar = "benchmark"++instance Read PathTemplateVariable where+  readsPrec _ s =+    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+  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'+    ]
+ src/Distribution/Simple/LocalBuildInfo.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.LocalBuildInfo+-- Copyright   :  Isaac Jones 2003-2004+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Once a package has been configured we have resolved conditionals and+-- dependencies, configured the compiler and other needed external programs.+-- The 'LocalBuildInfo' is used to hold all this information. It holds the+-- install dirs, the compiler, the exact package dependencies, the configured+-- 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++    -- * Convenience accessors+  , buildDir+  , packageRoot+  , progPrefix+  , progSuffix+  , interpretSymbolicPathLBI+  , mbWorkDirLBI+  , absoluteWorkingDirLBI+  , buildWays++    -- * Buildable package components+  , Component (..)+  , ComponentName (..)+  , LibraryName (..)+  , defaultLibName+  , showComponentName+  , componentNameString+  , ComponentLocalBuildInfo (..)+  , componentBuildDir+  , foldComponent+  , componentName+  , componentBuildInfo+  , componentBuildable+  , pkgComponents+  , pkgBuildableComponents+  , lookupComponent+  , getComponent+  , allComponentsInBuildOrder+  , depLibraryPaths+  , allLibModules+  , withAllComponentsInBuildOrder+  , withLibLBI+  , withExeLBI+  , withBenchLBI+  , withTestLBI+  , enabledTestLBIs+  , enabledBenchLBIs++    -- * Installation directories+  , module Distribution.Simple.InstallDirs+  , absoluteInstallDirs+  , prefixRelativeInstallDirs+  , absoluteInstallCommandDirs+  , absoluteComponentInstallDirs+  , prefixRelativeComponentInstallDirs+  , substPathTemplate+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Types.Component+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 qualified Distribution.Compat.Graph as Graph+import qualified Distribution.InstalledPackageInfo as Installed+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.Utils.Path++import Data.List (stripPrefix)+import qualified System.Directory as Directory+  ( canonicalizePath+  , doesDirectoryExist+  )++-- -----------------------------------------------------------------------------+-- Configuration information of buildable components++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 </>) $+    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 pkg lbi f =+  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 pkg lbi f =+  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 pkg lbi f =+  sequence_ [f bench clbi | (bench, clbi) <- enabledBenchLBIs pkg lbi]++withTestLBI+  :: PackageDescription+  -> LocalBuildInfo+  -> (TestSuite -> ComponentLocalBuildInfo -> IO ())+  -> IO ()+withTestLBI pkg lbi f =+  sequence_ [f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi]++enabledTestLBIs+  :: PackageDescription+  -> LocalBuildInfo+  -> [(TestSuite, ComponentLocalBuildInfo)]+enabledTestLBIs pkg lbi =+  [ (test, targetCLBI target)+  | target <- allTargetsInBuildOrder' pkg lbi+  , CTest test <- [targetComponent target]+  ]++enabledBenchLBIs+  :: PackageDescription+  -> LocalBuildInfo+  -> [(Benchmark, ComponentLocalBuildInfo)]+enabledBenchLBIs pkg lbi =+  [ (bench, targetCLBI target)+  | target <- allTargetsInBuildOrder' pkg lbi+  , CBench bench <- [targetComponent target]+  ]++-- | 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 pkg lbi f =+  withAllTargetsInBuildOrder' pkg lbi $ \target ->+    f (targetComponent target) (targetCLBI target)++allComponentsInBuildOrder+  :: LocalBuildInfo+  -> [ComponentLocalBuildInfo]+allComponentsInBuildOrder (LocalBuildInfo{componentGraph = compGraph}) =+  Graph.topSort compGraph++-- -----------------------------------------------------------------------------+-- A random function that has no business in this module++-- | Determine the directories containing the dynamic libraries of the+-- 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@( 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 = 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+    -- internal libraries?  The trouble is that 'installedPkgs'+    -- may contain *inplace* entries, which we must NOT use for+    -- not inplace 'depLibraryPaths' (e.g., for RPATH calculation).+    -- See #4025 for more details. This is all horrible but it+    -- is a moot point if you are using a per-component build,+    -- because you never have any internal libraries in this case;+    -- they're all external.+    let external_ipkgs = filter is_external (allPackages 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++        allDepLibDirs' = internalLibs ++ allDepLibDirs+    allDepLibDirsC <- traverse canonicalizePathNoFail allDepLibDirs'++    let p = prefix installDirs+        prefixRelative l = isJust (stripPrefix p l)+        libPaths+          | relative+              && prefixRelative relDir =+              map+                ( \l ->+                    if prefixRelative l+                      then shortRelativePath relDir l+                      else l+                )+                allDepLibDirsC+          | otherwise = allDepLibDirsC++    -- 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+        _ -> []++-- -----------------------------------------------------------------------------+-- Wrappers for a couple functions from InstallDirs++-- | Backwards compatibility function which computes the InstallDirs+-- 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 pkg lbi copydest =+  absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest++-- | See 'InstallDirs.absoluteInstallDirs'.+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 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'+    }+  where+    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+    dirs' = absoluteInstallDirs pkg lbi copydest++-- | Backwards compatibility function which computes the InstallDirs+-- 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 pkg_descr lbi =+  prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId 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
@@ -0,0 +1,816 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.PackageIndex+-- Copyright   :  (c) David Himmelstrup 2005,+--                    Bjorn Bringert 2007,+--                    Duncan Coutts 2008-2009+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- An index of packages whose primary key is 'UnitId'.  Public libraries+-- are additionally indexed by 'PackageName' and 'Version'.+-- Technically, these are an index of *units* (so we should eventually+-- rename it to 'UnitIndex'); but in the absence of internal libraries+-- or Backpack each unit is equivalent to a package.+--+-- While 'PackageIndex' is parametric over what it actually records,+-- it is in fact only ever instantiated with a single element:+-- The 'InstalledPackageIndex' (defined here) contains a graph of+-- 'InstalledPackageInfo's representing the packages in a+-- package database stack.  It is used in a variety of ways:+--+--   * The primary use to let Cabal access the same installed+--     package database which is used by GHC during compilation.+--     For example, this data structure is used by 'ghc-pkg'+--     and 'Cabal' to do consistency checks on the database+--     (are the references closed).+--+--   * Given a set of dependencies, we can compute the transitive+--     closure of dependencies.  This is to check if the versions+--     of packages are consistent, and also needed by multiple+--     tools (Haddock must be explicitly told about the every+--     transitive package to do cross-package linking;+--     preprocessors must know about the include paths of all+--     transitive dependencies.)+--+-- This 'PackageIndex' is NOT to be confused with+-- 'Distribution.Client.PackageIndex', which indexes packages only by+-- 'PackageName' (this makes it suitable for indexing source packages,+-- for which we don't know 'UnitId's.)+module Distribution.Simple.PackageIndex+  ( -- * Package index data type+    InstalledPackageIndex+  , PackageIndex++    -- * Creating an index+  , fromList++    -- * Updates+  , merge+  , insert+  , deleteUnitId+  , deleteSourcePackageId+  , deletePackageName+  --  deleteDependency,++    -- * Queries++    -- ** Precise lookups+  , lookupUnitId+  , lookupComponentId+  , lookupSourcePackageId+  , lookupPackageId+  , lookupPackageName+  , lookupInternalPackageName+  , lookupDependency+  , lookupInternalDependency++    -- ** Case-insensitive searches+  , searchByName+  , SearchResult (..)+  , searchByNameSubstring+  , searchWithPredicate++    -- ** Bulk queries+  , allPackages+  , allPackagesByName+  , allPackagesBySourcePackageId+  , allPackagesBySourcePackageIdAndLibName++    -- ** Special queries+  , brokenPackages+  , dependencyClosure+  , reverseDependencyClosure+  , topologicalOrder+  , reverseTopologicalOrder+  , dependencyInconsistencies+  , dependencyCycles+  , dependencyGraph+  , moduleNameIndex++    -- ** Filters on lookup results+  , eligibleDependencies+  , matchingDependencies+  ) where++import qualified Data.Map.Strict as Map+import Distribution.Compat.Prelude hiding (lookup)+import Prelude ()++import Distribution.Backpack+import qualified Distribution.InstalledPackageInfo as IPI+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 (deleteBy, deleteFirstsBy, groupBy)+import qualified Data.List.NonEmpty as NE+import qualified Data.Tree as Tree+import Distribution.Compat.Stack++import qualified Prelude (foldr1)++-- | The collection of information about packages from one or more 'PackageDB's.+-- These packages generally should have an instance of 'PackageInstalled'+--+-- 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)++instance Binary a => Binary (PackageIndex a)+instance Structured a => Structured (PackageIndex a)++-- | The default package index which contains 'InstalledPackageInfo'.  Normally+-- use this.+type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo++instance Monoid (PackageIndex IPI.InstalledPackageInfo) where+  mempty = PackageIndex Map.empty Map.empty+  mappend = (<>)++  -- save one mappend with empty in the common case:+  mconcat [] = mempty+  mconcat xs = Prelude.foldr1 mappend xs++instance Semigroup (PackageIndex IPI.InstalledPackageInfo) where+  (<>) = merge++{-# NOINLINE invariant #-}+invariant :: WithCallStack (InstalledPackageIndex -> Bool)+invariant (PackageIndex pids pnames) =+  -- trace (show pids' ++ "\n" ++ show pnames') $+  pids' == pnames'+  where+    pids' = map installedUnitId (Map.elems pids)+    pnames' =+      sort+        [ assert pinstOk (installedUnitId pinst)+        | ((pname, plib), pvers) <- Map.toList pnames+        , let pversOk = not (Map.null pvers)+        , (pver, pinsts) <- assert pversOk $ Map.toList pvers+        , let pinsts' = sortBy (comparing installedUnitId) pinsts+              pinstsOk =+                all+                  (\g -> length g == 1)+                  (groupBy (equating installedUnitId) pinsts')+        , pinst <- assert pinstsOk $ pinsts'+        , let pinstOk =+                packageName pinst == pname+                  && 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.++--++-- * Internal helpers++--++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++--++-- * 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 =+      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+        , let pvers =+                Map.fromList+                  [ ( packageVersion (NE.head pkgsNV)+                    , NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV)+                    )+                  | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN+                  ]+        ]++--++-- * Updates++--++-- | Merge two indexes.+--+-- Packages from the second mask packages from the first if they have the exact+-- same 'UnitId'.+--+-- For packages with the same source 'PackageId', packages from the second are+-- \"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 (PackageIndex pids1 pnames1) (PackageIndex pids2 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'+  where+    pids' = Map.insert (installedUnitId pkg) pkg pids+    pnames' = insertPackageName pnames+    insertPackageName =+      Map.insertWith+        (\_ -> insertPackageVersion)+        (packageName pkg, IPI.sourceLibName pkg)+        (Map.singleton (packageVersion pkg) [pkg])++    insertPackageVersion =+      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 ipkgid original@(PackageIndex pids pnames) =+  case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of+    (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)++    deletePkgInstance =+      (\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 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)+  where+    deletePkgName =+      Map.update deletePkgVersion (packageName pkgid, LMainLibName)++    deletePkgVersion =+      (\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 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)++{-+-- | Removes all packages satisfying this dependency from the index.+--+deleteDependency :: Dependency -> PackageIndex -> PackageIndex+deleteDependency (Dependency name verstionRange) =+  delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange)+-}++--++-- * Bulk queries++--++-- | Get all the packages from the index.+allPackages :: PackageIndex a -> [a]+allPackages = Map.elems . unitIdIndex++-- | Get all the packages from the index.+--+-- 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)+  ]++-- | 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 index =+  [ (packageId ipkg, ipkgs)+  | ((_, LMainLibName), pvers) <- Map.toList (packageIdIndex index)+  , 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 index =+  [ ((packageId ipkg, ln), ipkgs)+  | ((_, ln), pvers) <- Map.toList (packageIdIndex index)+  , 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 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 index cid =+  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 -> []+      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"++-- | Does a lookup by source package name.+lookupPackageName+  :: PackageIndex a+  -> PackageName+  -> [(Version, [a])]+lookupPackageName index name =+  -- Do not match internal libraries+  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.+--+-- We get back any number of versions of the specified package name, all+-- satisfying the version range constraint.+--+-- This does NOT work for internal dependencies, DO NOT use this+-- function on those; use 'lookupInternalDependency' instead.+--+-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty.+lookupDependency+  :: InstalledPackageIndex+  -> PackageName+  -> VersionRange+  -> [(Version, [IPI.InstalledPackageInfo])]+lookupDependency index pn vr =+  -- 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.+--+-- We get back any number of versions of the specified package name, all+-- satisfying the version range constraint.+--+-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty.+lookupInternalDependency+  :: InstalledPackageIndex+  -> PackageName+  -> VersionRange+  -> LibraryName+  -> [(Version, [IPI.InstalledPackageInfo])]+lookupInternalDependency index name versionRange libn =+  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.+--+-- If there is only one package that compares case-insensitively to this name+-- then the search is unambiguous and we get back all versions of that package.+-- If several match case-insensitively but one matches exactly then it is also+-- unambiguous.+--+-- If however several match case-insensitively and none match exactly then we+-- 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++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++-- | @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)+  , predicate (unPackageName pname)+  , pkgs <- Map.elems pvers+  , pkg <- pkgs+  ]++--++-- * Special queries++--++-- None of the stuff below depends on the internal representation of the index.+--++-- | Find if there are any cycles in the dependency graph. If there are no+-- cycles the result is @[]@.+--+-- 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]+  where+    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 index =+  [ (pkg, 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.+--+-- If the transitive closure is complete then it returns that subset of the+-- index. Otherwise it returns the broken packages as in 'brokenPackages'.+--+-- * 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 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+        Nothing -> closure completed' failed 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 index =+  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++reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a]+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 index = (graph, vertex_to_pkg, id_to_vertex)+  where+    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+    id_to_vertex pid = Map.lookup pid vertex_map++    vertex_to_pkg vertex = pkgTable ! vertex++    pkgTable = Array.listArray bounds pkgs+    topBound = length pkgs - 1+    bounds = (0, topBound)++-- | We maintain the invariant that, for any 'DepUniqueKey', there+-- is only one instance of the package in our database.+type DepUniqueKey = (PackageName, LibraryName, Map ModuleName OpenModule)++-- | Given a package index where we assume we want to use all the packages+-- (use 'dependencyClosure' if you need to get such a index subset) find out+-- if the dependencies within it use consistent versions of each package.+-- Return all cases where multiple packages depend on different versions of+-- some other package.+--+-- 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 index = do+  (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])++-- | A rough approximation of GHC's module finder, takes a+-- 'InstalledPackageIndex' and turns it into a map from module names to their+-- source packages.  It's used to initialize the @build-deps@ field in @cabal+-- init@.+moduleNameIndex :: InstalledPackageIndex -> Map ModuleName [IPI.InstalledPackageInfo]+moduleNameIndex index =+  Map.fromListWith (++) $ do+    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!
+ src/Distribution/Simple/PreProcess.hs view
@@ -0,0 +1,932 @@+{-# 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
@@ -0,0 +1,177 @@+-----------------------------------------------------------------------------++-- 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   :  ...+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Remove the \"literal\" markups from a Haskell source file, including+-- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\"+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++-- | 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)+  | "begin{code}" `isPrefixOf` s = BeginCode+  | "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++-- | '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 CabalException+unlit file input =+  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+    -- style literate code typically gets indented by two since ">" is replaced+    -- by " " and people usually use one additional space of indent ie+    -- "> then the code". On the other hand we cannot just go and indent all+    -- the comments by two since that does not work for latex style literate+    -- code. So the hacky solution we use here is that if we see any bird track+    -- style code then we'll indent all comments by two, otherwise by none.+    -- Of course this will not work for mixed latex/bird track .lhs files but+    -- nobody does that, it's silly and specifically recommended against in the+    -- H98 unlit spec.+    --+    classifyAndCheckForBirdTracks =+      flip mapAccumL False $ \seenBirdTrack line ->+        let classification = classify line+         in (seenBirdTrack || isBirdTrack classification, classification)++    isBirdTrack (BirdTrack _) = True+    isBirdTrack _ = False++    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,+-- if you count the error state), but the rules+-- to transition between then are not so simple.+-- Would it be simpler to have more states?+--+-- Each state represents the type of line that was last read+-- i.e. are we in a comment section, or a latex-code section,+-- or a bird-code section, etc?+reclassify :: [Classified] -> [Classified]+reclassify = blank -- begin in blank state+  where+    latex [] = []+    latex (EndCode : ls) = Blank "" : comment ls+    latex (BeginCode : _) = [Error "\\begin{code} in code section"]+    latex (BirdTrack l : ls) = Ordinary ('>' : l) : latex ls+    latex (l : ls) = l : latex ls++    blank [] = []+    blank (EndCode : _) = [Error "\\end{code} without \\begin{code}"]+    blank (BeginCode : ls) = Blank "" : latex ls+    blank (BirdTrack l : ls) = BirdTrack l : bird ls+    blank (Ordinary l : ls) = Comment l : comment ls+    blank (l : ls) = l : blank ls++    bird [] = []+    bird (EndCode : _) = [Error "\\end{code} without \\begin{code}"]+    bird (BeginCode : ls) = Blank "" : latex ls+    bird (Blank l : ls) = Blank l : blank ls+    bird (Ordinary _ : _) = [Error "program line before comment line"]+    bird (l : ls) = l : bird ls++    comment [] = []+    comment (EndCode : _) = [Error "\\end{code} without \\begin{code}"]+    comment (BeginCode : ls) = Blank "" : latex ls+    comment (CPP l : ls) = CPP l : comment ls+    comment (BirdTrack _ : _) = [Error "comment line before program line"]+    -- 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++-- 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 :))++internalError :: a+internalError = error "unlit: internal error"
+ src/Distribution/Simple/Program.hs view
@@ -0,0 +1,251 @@+{- 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+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This provides an abstraction which deals with configuring and running+-- programs. A 'Program' is a static notion of a known program. A+-- 'ConfiguredProgram' is a 'Program' that has been found on the current+-- machine and is ready to be run (possibly with some user-supplied default+-- args). Configuring a program involves finding its location and if necessary+-- finding its version. There is also a 'ProgramDb' type which holds+-- configured and not-yet configured programs. It is the parameter to lots of+-- actions elsewhere in Cabal that need to look up and run programs. If we had+-- a Cabal monad, the 'ProgramDb' would probably be a reader or+-- state component of it.+--+-- The module also defines all the known built-in 'Program's and the+-- 'defaultProgramDb' which contains them all.+--+-- One nice thing about using it is that any program that is+-- registered with Cabal will get some \"configure\" and \".cabal\"+-- helpers like --with-foo-args --foo-path= and extra-foo-args.+--+-- There's also good default behavior for trying to find \"foo\" in+-- PATH, being able to override its location, etc.+--+-- There's also a hook for adding programs in a Setup.lhs script.  See+-- 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++    -- * Configured program and related functions+  , ConfiguredProgram (..)+  , programPath+  , ProgArg+  , ProgramLocation (..)+  , runProgram+  , runProgramCwd+  , getProgramOutput+  , suppressOverrideArgs++    -- * Program invocations+  , ProgramInvocation (..)+  , emptyProgramInvocation+  , simpleProgramInvocation+  , programInvocation+  , runProgramInvocation+  , getProgramInvocationOutput+  , getProgramInvocationLBS++    -- * The collection of unconfigured and configured programs+  , 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+  , runDbProgramCwd+  , getDbProgramOutput+  , getDbProgramOutputCwd++    -- * Programs that Cabal knows about+  , 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 Distribution.Compat.Prelude+import Prelude ()++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 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 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.+runDbProgramCwd+  :: Verbosity+  -- ^ verbosity+  -> Maybe (SymbolicPath CWD (Dir to))+  -- ^ working directory+  -> Program+  -- ^ The program to run+  -> ProgramDb+  -- ^ look up the program here+  -> [ProgArg]+  -- ^ Any /extra/ arguments to add+  -> IO ()+runDbProgramCwd verbosity mbWorkDir prog programDb args =+  case lookupProgram prog programDb of+    Nothing ->+      dieWithException verbosity $ ProgramNotFound (programName prog)+    Just configuredProg -> 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 verb prog progDb args =+  getDbProgramOutputCwd verb Nothing prog progDb args++-- | Looks up the given program in the program database and runs it.+getDbProgramOutputCwd+  :: Verbosity+  -- ^ verbosity+  -> Maybe (SymbolicPath CWD (Dir to))+  -- ^ working directory+  -> Program+  -- ^ The program to run+  -> ProgramDb+  -- ^ look up the program here+  -> [ProgArg]+  -- ^ Any /extra/ arguments to add+  -> IO String+getDbProgramOutputCwd verbosity mbWorkDir prog programDb args =+  case lookupProgram prog programDb of+    Nothing -> dieWithException verbosity $ ProgramNotFound (programName prog)+    Just configuredProg ->+      getProgramInvocationOutput verbosity $+        programInvocationCwd mbWorkDir configuredProg args
+ src/Distribution/Simple/Program/Ar.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Program.Ar+-- Copyright   :  Duncan Coutts 2009+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module provides an library interface to the @ar@ program.+module Distribution.Simple.Program.Ar+  ( createArLibArchive+  , multiStageProgramInvocation+  ) where++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 (arDashLSupported, arResponseFilesSupported)+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI)+import Distribution.Simple.Program+  ( ProgramInvocation+  , arProgram+  , requireProgram+  )+import Distribution.Simple.Program.ResponseFile+  ( withResponseFile+  )+import Distribution.Simple.Program.Run+  ( multiStageProgramInvocation+  , programInvocationCwd+  , runProgramInvocation+  )+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Config+  ( configUseResponseFiles+  )+import Distribution.Simple.Utils+  ( defaultTempFileOptions+  , dieWithLocation'+  , withTempDirectoryCwd+  )+import Distribution.System+  ( Arch (..)+  , OS (..)+  , Platform (..)+  )+import Distribution.Utils.Path+import Distribution.Verbosity+  ( Verbosity+  , deafening+  , verbose+  )++import System.Directory (doesFileExist, renameFile)+import System.FilePath (splitFileName)+import System.IO+  ( Handle+  , IOMode (ReadWriteMode)+  , SeekMode (AbsoluteSeek)+  , hFileSize+  , hSeek+  , withBinaryFile+  )++-- | Call @ar@ to create a library archive from a bunch of object files.+createArLibArchive+  :: Verbosity+  -> LocalBuildInfo+  -> SymbolicPath Pkg File+  -> [SymbolicPath Pkg File]+  -> IO ()+createArLibArchive verbosity lbi targetPath files = do+  (arProg, _) <- requireProgram verbosity arProgram progDb++  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++    -- The args to use with "ar" are actually rather subtle and system-dependent.+    -- In particular we have the following issues:+    --+    --  -- On OS X, "ar q" does not make an archive index. Archives with no+    --     index cannot be used.+    --+    --  -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us+    --     do that. We have duplicates because of modules like "A.M" and "B.M"+    --     both make an object file "M.o" and ar does not consider the directory.+    --+    --  -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier+    --     in "q" mode which compels the archiver to add the members of an input+    --     archive to the output, rather than the archive itself. This is+    --     necessary as GHC may produce .o files that are actually archives. See+    --     https://gitlab.haskell.org/ghc/ghc/-/issues/21068.+    --+    -- Our solution is to use "ar r" in the simple case when one call is enough.+    -- When we need to call ar multiple times we use "ar q" and for the last+    -- call on OSX we use "ar qs" so that it'll make the index.++    let simpleArgs, initialArgs, finalArgs :: [String]+        simpleArgs = case hostOS of+          OSX -> ["-r", "-s"]+          _ | dashLSupported -> ["-qL"]+          _ -> ["-r"]++        initialArgs = ["-q"]+        finalArgs = case hostOS of+          OSX -> ["-q", "-s"]+          _ | dashLSupported -> ["-qL"]+          _ -> ["-q"]++        extraArgs = verbosityOpts verbosity ++ [u tmpPath]++        ar = programInvocationCwd mbWorkDir arProg+        simple = ar (simpleArgs ++ extraArgs)+        initial = ar (initialArgs ++ extraArgs)+        middle = initial+        final = ar (finalArgs ++ extraArgs)++        oldVersionManualOverride =+          fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi+        responseArgumentsNotSupported =+          not (arResponseFilesSupported (compiler lbi))+        dashLSupported =+          arDashLSupported (compiler lbi)++        invokeWithResponseFile :: FilePath -> ProgramInvocation+        invokeWithResponseFile atFile =+          (ar $ simpleArgs ++ extraArgs ++ ['@' : atFile])++    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.++-- | @ar@ by default includes various metadata for each object file in their+-- respective headers, so the output can differ for the same inputs, making+-- it difficult to avoid re-linking. GNU @ar@(1) has a deterministic mode+-- (@-D@) flag that always writes zero for the mtime, UID and GID, and 0644+-- for the file mode. However detecting whether @-D@ is supported seems+-- 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+  where+    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+        [ "0           " -- mtime, 12 bytes+        , "0     " -- UID, 6 bytes+        , "0     " -- GID, 6 bytes+        , "0644    " -- mode, 8 bytes+        ]+    headerSize :: Int+    headerSize = 60++    -- 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)+      where+        wipeHeader :: Integer -> IO ()+        wipeHeader offset = case compare offset archiveSize of+          EQ -> return ()+          GT -> wipeError (atOffset "Archive truncated")+          LT -> do+            header <- BS.hGet h headerSize+            unless (BS.length header == headerSize) $+              wipeError (atOffset "Short header")+            let magic = BS.drop 58 header+            unless (magic == x60LF) . wipeError . atOffset $+              "Bad magic " ++ show magic ++ " in header"++            let name = BS.take 16 header+            let size = BS.take 10 $ BS.drop 48 header+            objSize <- case reads (BS8.unpack size) of+              [(n, s)] | all isSpace s -> return n+              _ -> wipeError (atOffset "Bad file size in header")++            let replacement = BS.concat [name, metadata, size, magic]+            unless (BS.length replacement == headerSize) $+              wipeError (atOffset "Something has gone terribly wrong")+            hSeek h AbsoluteSeek offset+            BS.hPut h replacement++            let nextHeader =+                  offset+                    + toInteger headerSize+                    ++                    -- Odd objects are padded with an extra '\x0a'+                    if odd objSize then objSize + 1 else objSize+            hSeek h AbsoluteSeek nextHeader+            wipeHeader nextHeader+          where+            atOffset msg = msg ++ " at offset " ++ show offset
+ src/Distribution/Simple/Program/Builtin.hs view
@@ -0,0 +1,386 @@+-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Program.Builtin+-- Copyright   :  Isaac Jones 2006, Duncan Coutts 2007-2009+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- 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++    -- * Programs that Cabal knows about+  , 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 Distribution.Compat.Prelude+import Prelude ()++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+import Distribution.Simple.Utils+import Distribution.Verbosity+import Distribution.Version++import qualified Data.Map as Map++-- ------------------------------------------------------------++-- * Known programs++-- ------------------------------------------------------------++-- | The default list of programs.+-- These programs are typically used internally to Cabal.+builtinPrograms :: [Program]+builtinPrograms =+  [ -- compilers and related progs+    ghcProgram+  , runghcProgram+  , ghcPkgProgram+  , ghcjsProgram+  , ghcjsPkgProgram+  , 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+    , programPostConf = ghcPostConf+    , programNormaliseArgs = normaliseGhcArgs+    }+  where+    ghcPostConf _verbosity ghcProg = do+      let setLanguageEnv prog =+            prog+              { programOverrideEnv =+                  ("LANGUAGE", Just "en")+                    : programOverrideEnv ghcProg+              }++          ignorePackageEnv prog = prog{programDefaultArgs = "-package-env=-" : programDefaultArgs prog}++          -- 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+          _ -> ""+    }++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+          _ -> ""+    }++ghcjsProgram :: Program+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+          _ -> ""+    }++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+          _ -> ""+    }++uhcProgram :: Program+uhcProgram =+  (simpleProgram "uhc")+    { programFindVersion = findProgramVersion "--version-dotted" id+    }++hpcProgram :: Program+hpcProgram =+  (simpleProgram "hpc")+    { programFindVersion = findProgramVersion "version" $ \str ->+        case words str of+          (_ : _ : _ : ver : _) -> ver+          _ -> ""+    }++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+          _ -> ""+    }++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+          _ -> ""+    }++gccProgram :: Program+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)+    }++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+            _ -> ""+    }++c2hsProgram :: Program+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+          _ -> ""+    }++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+          _ -> ""+    }++-- 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+          _ -> ""+    }++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+    }++ldProgram :: Program+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}+    }++cppProgram :: Program+cppProgram = simpleProgram "cpp"++pkgConfigProgram :: Program+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
@@ -0,0 +1,566 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Program.Db+-- Copyright   :  Isaac Jones 2006, Duncan Coutts 2007-2009+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This provides a 'ProgramDb' type which holds configured and not-yet+-- configured programs. It is the parameter to lots of actions elsewhere in+-- Cabal that need to look up and run programs. If we had a Cabal monad,+-- the 'ProgramDb' would probably be a reader or state component of it.+--+-- One nice thing about using it is that any program that is+-- registered with Cabal will get some \"configure\" and \".cabal\"+-- helpers like --with-foo-args --foo-path= and extra-foo-args.+--+-- There's also a hook for adding programs in a Setup.lhs script.  See+-- 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++    -- ** Query and manipulate the program db+  , 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+  , configureUnconfiguredProgram+  , configureAllKnownPrograms+  , unconfigureProgram+  , lookupProgramVersion+  , reconfigurePrograms+  , requireProgram+  , requireProgramVersion+  , needProgram++    -- * Internal functions+  , UnconfiguredProgs+  , ConfiguredProgs+  , updateUnconfiguredProgs+  , updateConfiguredProgs+  ) where++import Distribution.Compat.Prelude+import Prelude ()++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.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+-- contains information both about configured programs and also about programs+-- that we are yet to configure.+--+-- The idea is that we start from a collection of unconfigured programs and one+-- 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+  , progOverrideEnv :: [(String, Maybe String)]+  , configuredProgs :: ConfiguredProgs+  }++type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg])+type UnconfiguredProgs = Map.Map String UnconfiguredProgram+type ConfiguredProgs = Map.Map String ConfiguredProgram++emptyProgramDb :: ProgramDb+emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath [] Map.empty++defaultProgramDb :: ProgramDb+defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb++-- internal helpers:+updateUnconfiguredProgs+  :: (UnconfiguredProgs -> UnconfiguredProgs)+  -> ProgramDb+  -> ProgramDb+updateUnconfiguredProgs update progdb =+  progdb{unconfiguredProgs = update (unconfiguredProgs progdb)}++updateConfiguredProgs+  :: (ConfiguredProgs -> ConfiguredProgs)+  -> ProgramDb+  -> ProgramDb+updateConfiguredProgs update 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+    ]++-- | 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+    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 [(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+-- it contains functions. So to fully restore a deserialised 'ProgramDb' use+-- this function to add back all the known 'Program's.+--+-- * 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)++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++knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)]+knownPrograms 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}++-- | 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 f db =+  setProgramSearchPath (f $ getProgramSearchPath db) db++-- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'+-- by prepending the provided extra paths.+--+--  - Logs the added paths in info verbosity.+--  - Prepends environment variable overrides.+prependProgramSearchPath+  :: Verbosity+  -> [FilePath]+  -> [(String, Maybe FilePath)]+  -> ProgramDb+  -> IO ProgramDb+prependProgramSearchPath verbosity extraPaths 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''++-- | 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+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'+                }+      )++-- | Like 'userSpecifyPath' but for a list of progs and their paths.+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 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++-- | 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++-- -----------------------------+-- Managing configured programs++-- | Try to find a configured program+lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram+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++-- | List all configured programs.+configuredPrograms :: ProgramDb -> [ConfiguredProgram]+configuredPrograms = Map.elems . configuredProgs++-- ---------------------------+-- Configuring known programs++-- | 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.+--+-- The reason for it not being a failure at this stage is that we don't know up+-- 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 prog progdb = do+  mbConfiguredProg <- configureUnconfiguredProgram verbosity prog progdb+  case mbConfiguredProg of+    Nothing -> return progdb+    Just configuredProg -> do+      let progdb' =+            updateConfiguredProgs+              (Map.insert (programName prog) configuredProg)+              progdb+      return progdb'++-- | Try to configure a specific program. If the program is already included in+-- the collection of unconfigured programs then we use any user-supplied+-- location and arguments.+configureUnconfiguredProgram+  :: Verbosity+  -> Program+  -> ProgramDb+  -> IO (Maybe ConfiguredProgram)+configureUnconfiguredProgram verbosity prog progdb = do+  let name = programName prog+  maybeLocation <- case userSpecifiedPath prog progdb of+    Nothing ->+      programFindLocation prog verbosity (progSearchPath progdb)+        >>= return . fmap (swap . fmap FoundOnSystem . swap)+    Just path -> do+      absolute <- doesExecutableExist path+      if absolute+        then return (Just (UserSpecified path, []))+        else+          findProgramOnSearchPath verbosity (progSearchPath progdb) path+            >>= maybe+              (dieWithException verbosity $ ConfigureProgram name path)+              (return . Just . swap . fmap UserSpecified . swap)+  case maybeLocation of+    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)] ++ progOverrideEnv progdb+              , programProperties = Map.empty+              , programLocation = location+              , programMonitorFiles = triedLocations+              }+      configuredProg' <- programPostConf prog verbosity configuredProg+      return $ Just configuredProg'++-- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'.+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.+unconfigureProgram :: String -> ProgramDb -> ProgramDb+unconfigureProgram progname =+  updateConfiguredProgs $ Map.delete progname++-- | Try to configure all the known programs that have not yet been configured.+configureAllKnownPrograms+  :: Verbosity+  -> ProgramDb+  -> IO ProgramDb+configureAllKnownPrograms verbosity progdb =+  configurePrograms+    verbosity+    [prog | (prog, _, _) <- Map.elems notYetConfigured]+    progdb+  where+    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 paths argss progdb = do+  configurePrograms verbosity progs+    . userSpecifyPaths paths+    . userSpecifyArgss argss+    $ progdb+  where+    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 prog progdb = do+  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.+--+-- It returns 'Nothing' if the program couldn't be configured,+-- or is not found.+--+-- @since 3.0.1.0+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++  case lookupProgram prog progdb' of+    Nothing -> return Nothing+    Just configuredProg -> return (Just (configuredProg, progdb'))++-- | Check that a program is configured and available to be run.+--+-- Additionally check that the program version number is suitable and return+-- it. For example you could require 'AnyVersion' or @'orLaterVersion'+-- ('Version' [1,0] [])@+--+-- 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 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++  case lookupProgram prog programDb' of+    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 $ 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 prog range programDb =+  join $+    either (dieWithException verbosity) return+      `fmap` lookupProgramVersion verbosity prog range programDb
+ src/Distribution/Simple/Program/Find.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Program.Find+-- Copyright   :  Duncan Coutts 2013+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- A somewhat extended notion of the normal program search path concept.+--+-- Usually when finding executables we just want to look in the usual places+-- using the OS's usual method for doing so. In Haskell the normal OS-specific+-- method is captured by 'findExecutable'. On all common OSs that makes use of+-- a @PATH@ environment variable, (though on Windows it is not just the @PATH@).+--+-- However it is sometimes useful to be able to look in additional locations+-- without having to change the process-global @PATH@ environment variable.+-- 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+  , logExtraProgramSearchPath+  , logExtraProgramOverrideEnv+  , getSystemSearchPath+  , getExtraPathEnv+  , simpleProgram+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Compat.Environment+import Distribution.Simple.Program.Types+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Verbosity++import qualified System.Directory as Directory+  ( findExecutable+  )+import System.FilePath as FilePath+  ( getSearchPath+  , searchPathSeparator+  , splitSearchPath+  , takeDirectory+  , (<.>)+  , (</>)+  )+#if defined(mingw32_HOST_OS)+import qualified System.Win32 as Win32+#endif++defaultProgramSearchPath :: ProgramSearchPath+defaultProgramSearchPath = [ProgramSearchPathDefault]++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+  where+    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+        (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]+    -- 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]+      syspath <- getSystemSearchPath+      case mExe of+        Nothing ->+          let notfoundat = [dir </> prog | dir <- syspath]+           in return (Nothing, notfoundat)+        Just foundat -> do+          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 :: [FilePath] -> IO (Maybe FilePath, [FilePath])+    findFirstExe = go []+      where+        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++    -- 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+      a <- ma+      case a of+        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))+  where+    getEntries (ProgramSearchPathDir dir) = return [dir]+    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)+    processdir <- takeDirectory `fmap` Win32.getModuleFileName Win32.nullHANDLE+    currentdir <- Win32.getCurrentDirectory+    systemdir  <- Win32.getSystemDirectory+    windowsdir <- Win32.getWindowsDirectory+    pathdirs   <- FilePath.getSearchPath+    let path = processdir : currentdir+             : systemdir  : windowsdir+             : pathdirs+    return path+#else+    FilePath.getSearchPath+#endif++#ifdef MIN_VERSION_directory+#if MIN_VERSION_directory(1,2,1)+#define HAVE_directory_121+#endif+#endif++findExecutable :: FilePath -> IO (Maybe FilePath)+#ifdef HAVE_directory_121+findExecutable = Directory.findExecutable+#else+findExecutable prog = do+      -- With directory < 1.2.1 'findExecutable' doesn't check that the path+      -- really refers to an executable.+      mExe <- Directory.findExecutable prog+      case mExe of+        Just exe -> do+          exeExists <- doesExecutableExist exe+          if exeExists+            then return mExe+            else return Nothing+        _     -> return mExe+#endif++-- | Make a simple named program.+--+-- 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
@@ -0,0 +1,1085 @@+{-# 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++instance Monoid GhcOptions where+  mempty = gmempty+  mappend = (<>)++instance Semigroup GhcOptions where+  (<>) = gmappend
+ src/Distribution/Simple/Program/HcPkg.hs view
@@ -0,0 +1,596 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Program.HcPkg+-- Copyright   :  Duncan Coutts 2009, 2013+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- 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++    -- * Actions+  , init+  , invoke+  , register+  , unregister+  , recache+  , expose+  , hide+  , dump+  , describe+  , list++    -- * Program invocations+  , initInvocation+  , registerInvocation+  , unregisterInvocation+  , recacheInvocation+  , exposeInvocation+  , hideInvocation+  , dumpInvocation+  , describeInvocation+  , listInvocation+  ) where++import Distribution.Compat.Prelude hiding (init)+import Prelude ()++import Distribution.InstalledPackageInfo+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 qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List.NonEmpty as NE+import qualified System.FilePath.Posix as FilePath.Posix++-- | Information about the features and capabilities of an @hc-pkg@+--   program.+data HcPkgInfo = HcPkgInfo+  { hcPkgProgram :: ConfiguredProgram+  , noPkgDbStack :: Bool+  -- ^ no package DB stack supported+  , noVerboseFlag :: Bool+  -- ^ hc-pkg does not support verbosity flags+  , flagPackageConf :: Bool+  -- ^ use package-conf option instead of package-db+  , supportsDirDbs :: Bool+  -- ^ supports directory style package databases+  , requiresDirDbs :: Bool+  -- ^ requires directory style package databases+  , nativeMultiInstance :: Bool+  -- ^ supports --enable-multi-instance flag+  , recacheMultiInstance :: Bool+  -- ^ supports multi-instance via recache+  , suppressFilesCheck :: Bool+  -- ^ supports --force-files or equivalent+  }++-- | Call @hc-pkg@ to initialise a package database at the location {path}.+--+-- > hc-pkg init {path}+init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO ()+init hpi verbosity preferCompat path+  | not (supportsDirDbs hpi)+      || (not (requiresDirDbs hpi) && preferCompat) =+      writeFile path "[]"+  | otherwise =+      runProgramInvocation verbosity (initInvocation hpi verbosity path)++-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the+-- provided command-line arguments to it.+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 = programInvocationCwd mbWorkDir (hcPkgProgram hpi) args++-- | Additional variations in the behaviour for 'register'.+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+    }++-- | Call @hc-pkg@ to register a package.+--+-- > hc-pkg register {filename | -} [--user | --global | --package-db]+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) =+      dieWithException verbosity RegMultipleInstancePkg+  | registerSuppressFilesCheck registerOptions+  , not (suppressFilesCheck hpi) =+      dieWithException verbosity SuppressingChecksOnFile+  -- This is a trick. Older versions of GHC do not support the+  -- --enable-multi-instance flag for ghc-pkg register but it turns out that+  -- the same ability is available by using ghc-pkg recache. The recache+  -- command is there to support distro package managers that like to work+  -- by just installing files and running update commands, rather than+  -- special add/remove commands. So the way to register by this method is+  -- to write the package registration file directly into the package db and+  -- then call hc-pkg recache.+  --+  | registerMultiInstance registerOptions+  , recacheMultiInstance hpi =+      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 -> 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 -> 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+  -> 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+  -> 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+    _ -> 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+  -> 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+  -> 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+    _ -> 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)+  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++        isSpace8 :: Word8 -> Bool+        isSpace8 9 = True -- '\t'+        isSpace8 10 = True -- '\n'+        isSpace8 13 = True -- '\r'+        isSpace8 32 = True -- ' '+        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+                    Just sfx' -> LBS.toStrict pfx : doSplit sfx'+                    Nothing -> go idxs++            separators :: [LBS.ByteString]+            separators = ["\n---\n", "\r\n---\r\n", "\r---\r"]++lbsStripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString+#if MIN_VERSION_bytestring(0,10,8)+lbsStripPrefix pfx lbs = LBS.stripPrefix pfx lbs+#else+lbsStripPrefix pfx lbs+    | LBS.isPrefixOf pfx lbs = Just (LBS.drop (LBS.length pfx) lbs)+    | otherwise              = Nothing+#endif++mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo+-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec+-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)+-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.+-- The "pkgroot" is the directory containing the package database.+mungePackagePaths pkgroot pkginfo =+  pkginfo+    { importDirs = mungePaths (importDirs pkginfo)+    , includeDirs = mungePaths (includeDirs pkginfo)+    , libraryDirs = mungePaths (libraryDirs pkginfo)+    , libraryDirsStatic = mungePaths (libraryDirsStatic pkginfo)+    , libraryDynDirs = mungePaths (libraryDynDirs pkginfo)+    , frameworkDirs = mungePaths (frameworkDirs pkginfo)+    , haddockInterfaces = mungePaths (haddockInterfaces pkginfo)+    , haddockHTMLs = mungeUrls (haddockHTMLs pkginfo)+    }+  where+    mungePaths = map mungePath+    mungeUrls = map mungeUrl++    mungePath p = case stripVarPrefix "${pkgroot}" p of+      Just p' -> pkgroot </> p'+      Nothing -> p++    mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of+      Just p' -> toUrlPath pkgroot p'+      Nothing -> 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+          Just [sep] | isPathSeparator sep -> Just (joinPath path')+          _ -> 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 = 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+  -> 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+    _ -> dieWithException verbosity $ FailedToParseOutputList (programId (hcPkgProgram hpi))+  where+    parsePackageIds = traverse simpleParsec . words++--------------------------+-- The program invocations+--++initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation+initInvocation hpi verbosity path =+  programInvocation (hcPkgProgram hpi) args+  where+    args =+      ["init", path]+        ++ verbosityOpts hpi verbosity++registerInvocation+  :: HcPkgInfo+  -> Verbosity+  -> Maybe (SymbolicPath CWD (Dir from))+  -> PackageDBStackS from+  -> InstalledPackageInfo+  -> RegisterOptions+  -> ProgramInvocation+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+  -> 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++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++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++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+  -> 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]+        ++ 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+  -> 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]+        ++ verbosityOpts hpi silent++-- We use verbosity level 'silent' because it is important that we+-- do not contaminate the output with info/debug messages.++packageDbStackOpts :: HcPkgInfo -> PackageDBStackS from -> [String]+packageDbStackOpts hpi dbstack+  | noPkgDbStack hpi = [packageDbOpts hpi (registrationPackageDB dbstack)]+  | otherwise = case dbstack of+      (GlobalPackageDB : UserPackageDB : dbs) ->+        "--global"+          : "--user"+          : map specific dbs+      (GlobalPackageDB : dbs) ->+        "--global"+          : ("--no-user-" ++ packageDbFlag hpi)+          : map specific dbs+      _ -> ierror+  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"++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 =+      []+  | v >= deafening = ["-v2"]+  | v == silent = ["-v0"]+  | otherwise = []
+ src/Distribution/Simple/Program/Hpc.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Program.Hpc+-- Copyright   :  Thomas Tuegel 2011+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module provides an library interface to the @hpc@ program.+module Distribution.Simple.Program.Hpc+  ( markup+  , union+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.ModuleName+import Distribution.Pretty+import Distribution.Simple.Program.Run+import Distribution.Simple.Program.Types+import Distribution.Simple.Utils+import Distribution.Utils.Path+import Distribution.Verbosity+import Distribution.Version++-- | Invoke hpc with the given parameters.+--+-- Prior to HPC version 0.7 (packaged with GHC 7.8), hpc did not handle+-- multiple .mix paths correctly, so we print a warning, and only pass it the+-- 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+  :: 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 (tryMakeRelative mbWorkDir) hpcDirs'++  runProgramInvocation+    verbosity+    (markupInvocation mbWorkDir hpc tixFile hpcDirs'' destDir included)+  where+    version07 = mkVersion [0, 7]+    (passedDirs, droppedDirs) = splitAt 1 hpcDirs++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+  :: 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+  :: 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
@@ -0,0 +1,53 @@+-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Program.Internal+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Internal utilities used by Distribution.Simple.Program.*.+module Distribution.Simple.Program.Internal+  ( stripExtractVersion+  ) where++import Distribution.Compat.Prelude+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, non-LLVM 'strip' doesn't appear to have+-- a version flag.+stripExtractVersion :: String -> String+stripExtractVersion str =+  let numeric "" = False+      numeric (x : _) = isDigit x++      closingParentheses =+        [ ")"+        , -- LLVM strip outputs "llvm-strip, compatible with GNU strip\nLLVM (http://llvm.org/):\n..."+          "):"+        ]++      -- Filter out everything in parentheses.+      filterPar' :: Int -> [String] -> [String]+      filterPar' _ [] = []+      filterPar' n (x : xs)+        | n >= 0 && "(" `isPrefixOf` x = filterPar' (n + 1) ((safeTail x) : xs)+        | n > 0 && 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+        _ -> ""
+ src/Distribution/Simple/Program/Ld.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Program.Ld+-- Copyright   :  Duncan Coutts 2009+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module provides an library interface to the @ld@ linker program.+module Distribution.Simple.Program.Ld+  ( combineObjectFiles+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Simple.Compiler (arResponseFilesSupported)+import Distribution.Simple.Flag+  ( fromFlagOrDefault+  )+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI)+import Distribution.Simple.Program.ResponseFile+  ( withResponseFile+  )+import Distribution.Simple.Program.Run+  ( ProgramInvocation+  , multiStageProgramInvocation+  , programInvocationCwd+  , runProgramInvocation+  )+import Distribution.Simple.Program.Types+  ( ConfiguredProgram (..)+  )+import Distribution.Simple.Setup.Config+  ( configUseResponseFiles+  )+import Distribution.Simple.Utils+  ( defaultTempFileOptions+  )+import Distribution.Utils.Path+import Distribution.Verbosity+  ( Verbosity+  )++import System.Directory+  ( renameFile+  )++-- | Call @ld -r@ to link a bunch of object files together.+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+    -- See Note [Symbolic paths] in Distribution.Utils.Path+    u :: SymbolicPath Pkg to -> FilePath+    u = interpretSymbolicPathCWD+    i = interpretSymbolicPath mbWorkDir+    mbWorkDir = mbWorkDirLBI lbi++    simpleArgs = ["-r", "-o", u target]+    initialArgs = ["-r", "-o", u target]+    middleArgs = ["-r", "-o", u target, u tmpfile]+    finalArgs = middleArgs++    ld = programInvocationCwd (mbWorkDirLBI lbi) ldProg+    simple = ld simpleArgs+    initial = ld initialArgs+    middle = ld middleArgs+    final = ld finalArgs++    invokeWithResponseFile :: FilePath -> ProgramInvocation+    invokeWithResponseFile atFile =+      ld $ simpleArgs ++ ['@' : atFile]++    oldVersionManualOverride =+      fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi+    -- Whether ghc's ar supports response files is a good proxy for+    -- whether ghc's ld supports them as well.+    responseArgumentsNotSupported =+      not (arResponseFilesSupported (compiler lbi))++    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) (map getSymbolicPath files)+    else withResponseFile verbosity defaultTempFileOptions "ld.rsp" Nothing (map getSymbolicPath files) $+      \path -> runProgramInvocation verbosity $ invokeWithResponseFile path+  where+    tmpfile = target <.> "tmp" -- perhaps should use a proper temp file
+ src/Distribution/Simple/Program/ResponseFile.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++----------------------------------------------------------------------------++----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Program.ResponseFile+-- Copyright   :  (c) Sergey Vinokurov 2017+-- License     :  BSD3-style+--+-- 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 Distribution.Compat.Prelude+import Distribution.Simple.Utils (TempFileOptions, debug, withTempFileEx)+import Distribution.Utils.Path+import Distribution.Verbosity++withResponseFile+  :: Verbosity+  -> TempFileOptions+  -> 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 fileNameTemplate encoding arguments f =+  withTempFileEx tmpFileOpts fileNameTemplate $ \responsePath hf -> do+    let responseFileName = getSymbolicPath responsePath+    traverse_ (hSetEncoding hf) encoding+    let responseContents =+          unlines $+            map escapeResponseFileArg $+              arguments+    hPutStr hf responseContents+    hClose hf+    debug verbosity $ responseFileName ++ " contents: <<<"+    debug verbosity responseContents+    debug verbosity $ ">>> " ++ responseFileName+    f responseFileName++-- Support a gcc-like response file syntax.  Each separate+-- argument and its possible parameter(s), will be separated in the+-- response file by an actual newline; all other whitespace,+-- single quotes, double quotes, and the character used for escaping+-- (backslash) are escaped.  The called program will need to do a similar+-- inverse operation to de-escape and re-constitute the argument list.+escapeResponseFileArg :: String -> String+escapeResponseFileArg = reverse . foldl' escape []+  where+    escape :: String -> Char -> String+    escape cs c =+      case c of+        '\\' -> c : '\\' : cs+        '\'' -> c : '\\' : cs+        '"' -> c : '\\' : cs+        _+          | isSpace c -> c : '\\' : cs+          | otherwise -> c : cs
+ src/Distribution/Simple/Program/Run.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Program.Run+-- Copyright   :  Duncan Coutts 2009+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module provides a data type for program invocations and functions to+-- run them.+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 qualified Data.ByteString.Lazy as LBS+import qualified Data.Map as Map++-- | Represents a specific invocation of a specific program.+--+-- This is used as an intermediate type between deciding how to call a program+-- 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)]+  , 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++encodeToIOData :: IOEncoding -> IOData -> IOData+encodeToIOData _ iod@(IODataBinary _) = iod+encodeToIOData IOEncodingText iod@(IODataText _) = iod+encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str)++emptyProgramInvocation :: ProgramInvocation+emptyProgramInvocation =+  ProgramInvocation+    { progInvokePath = ""+    , progInvokeArgs = []+    , progInvokeEnv = []+    , progInvokeCwd = Nothing+    , progInvokeInput = Nothing+    , progInvokeInputEncoding = IOEncodingText+    , progInvokeOutputEncoding = IOEncodingText+    , progInvokeWhen = pure True+    }++simpleProgramInvocation+  :: FilePath+  -> [String]+  -> ProgramInvocation+simpleProgramInvocation path args =+  emptyProgramInvocation+    { progInvokePath = path+    , progInvokeArgs = args+    }++programInvocation+  :: ConfiguredProgram+  -> [String]+  -> ProgramInvocation+programInvocation prog args =+  emptyProgramInvocation+    { progInvokePath = programPath prog+    , progInvokeArgs =+        programDefaultArgs prog+          ++ args+          ++ programOverrideArgs prog+    , progInvokeEnv = programOverrideEnv prog+    }++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 = []+    , 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) $+      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++getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO LBS.ByteString+getProgramInvocationLBS verbosity inv = do+  (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 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)++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)+getProgramInvocationIODataAndErrors+  verbosity+  ProgramInvocation+    { progInvokePath = path+    , progInvokeArgs = args+    , progInvokeEnv = envOverrides+    , progInvokeCwd = mcwd+    , progInvokeInput = minputStr+    , progInvokeInputEncoding = encoding+    }+  mode = do+    menv <- getEffectiveEnvironment envOverrides+    rawSystemStdInOut verbosity path args mcwd menv input mode+    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 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+  where+    apply os env = foldl' (flip update) env os+    update (var, Nothing) = Map.delete var+    update (var, Just val) = Map.insert var val++-- | Like 'getEffectiveEnvironment', but when no overrides are specified,+-- returns the full environment instead of 'Nothing'.+getFullEnvironment+  :: [(String, Maybe String)]+  -> IO [(String, String)]+getFullEnvironment overrides = do+  menv <- getEffectiveEnvironment overrides+  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.+--+-- It takes four template invocations corresponding to the simple, initial,+-- middle and last invocations. If the number of args given is small enough+-- that we can get away with just a single invocation then the simple one is+-- used:+--+-- > $ simple args+--+-- If the number of args given means that we need to use multiple invocations+-- then the templates for the initial, middle and last invocations are used:+--+-- > $ initial args_0+-- > $ middle  args_1+-- > $ 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)+      fixedArgSize = maximum (map argSize [simple, initial, middle, final])+      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]+  where+    appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation+    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)++    chunk :: Int -> [[a]] -> ([[a]], [[a]])+    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!"++-- 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+--+maxCommandLineSize :: Int+maxCommandLineSize = 30 * 1024
+ src/Distribution/Simple/Program/Script.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Program.Script+-- Copyright   :  Duncan Coutts 2009+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- 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+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Simple.Program.Run+import Distribution.Simple.Utils+import Distribution.System++-- | Generate a system script, either POSIX shell script or Windows batch file+-- as appropriate for the given system.+invocationAsSystemScript :: OS -> ProgramInvocation -> String+invocationAsSystemScript Windows = invocationAsBatchFile+invocationAsSystemScript _ = invocationAsShellScript++-- | Generate a POSIX shell script that invokes a program.+invocationAsShellScript :: ProgramInvocation -> String+invocationAsShellScript+  ProgramInvocation+    { progInvokePath = path+    , progInvokeArgs = args+    , progInvokeEnv = envExtra+    , progInvokeCwd = mcwd+    , progInvokeInput = minput+    } =+    unlines $+      ["#!/bin/sh"]+        ++ concatMap setEnv envExtra+        ++ ["cd " ++ quote cwd | cwd <- maybeToList mcwd]+        ++ [ ( case minput of+                Nothing -> ""+                Just input -> "printf '%s' " ++ quote (iodataToText input) ++ " | "+             )+              ++ unwords (map quote $ path : args)+              ++ " \"$@\""+           ]+    where+      setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var]+      setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val]++      quote :: String -> String+      quote s = "'" ++ escape s ++ "'"++      escape [] = []+      escape ('\'' : cs) = "'\\''" ++ escape cs+      escape (c : cs) = c : escape cs++iodataToText :: IOData -> String+iodataToText (IODataText str) = str+iodataToText (IODataBinary lbs) = fromUTF8LBS lbs++-- | Generate a Windows batch file that invokes a program.+invocationAsBatchFile :: ProgramInvocation -> String+invocationAsBatchFile+  ProgramInvocation+    { progInvokePath = path+    , progInvokeArgs = args+    , progInvokeEnv = envExtra+    , progInvokeCwd = mcwd+    , progInvokeInput = minput+    } =+    unlines $+      ["@echo off"]+        ++ map setEnv envExtra+        ++ ["cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd]+        ++ case minput of+          Nothing ->+            [path ++ concatMap (' ' :) args]+          Just input ->+            ["("]+              ++ ["echo " ++ escape line | line <- lines $ iodataToText input]+              ++ [ ") | "+                    ++ "\""+                    ++ path+                    ++ "\""+                    ++ concatMap (\arg -> ' ' : quote arg) args+                 ]+    where+      setEnv (var, Nothing) = "set " ++ var ++ "="+      setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val++      quote :: String -> String+      quote s = "\"" ++ escapeQ s ++ "\""++      escapeQ [] = []+      escapeQ ('"' : cs) = "\"\"\"" ++ escapeQ cs+      escapeQ (c : cs) = c : escapeQ cs++      escape [] = []+      escape ('|' : cs) = "^|" ++ escape cs+      escape ('<' : cs) = "^<" ++ escape cs+      escape ('>' : cs) = "^>" ++ escape cs+      escape ('&' : cs) = "^&" ++ escape cs+      escape ('(' : cs) = "^(" ++ escape cs+      escape (')' : cs) = "^)" ++ escape cs+      escape ('^' : cs) = "^^" ++ escape cs+      escape (c : cs) = c : escape cs
+ src/Distribution/Simple/Program/Strip.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Program.Strip+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module provides an library interface to the @strip@ program.+module Distribution.Simple.Program.Strip (stripLib, stripExe)+where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Simple.Program+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Verbosity+import Distribution.Version++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)"++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.+      _ -> []++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 ()+    IOS -> return ()+    AIX -> return ()+    Solaris -> return ()+    OpenBSD ->+      -- '--strip-unneeded' sometimes strips too much on OpenBSD.+      -- -- See https://cvsweb.openbsd.org/cgi-bin/cvsweb/~checkout~/ports/lang/ghc/patches/patch-libraries_Cabal_Cabal_Distribution_Simple_Program_Strip_hs+      return ()+    Windows ->+      -- Stripping triggers a bug in 'strip.exe' for+      -- libraries with lots identically named modules. See+      -- #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
@@ -0,0 +1,189 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Program.Types+-- Copyright   :  Isaac Jones 2006, Duncan Coutts 2007-2009+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This provides an abstraction which deals with configuring and running+-- programs. A 'Program' is a static notion of a known program. A+-- 'ConfiguredProgram' is a 'Program' that has been found on the current+-- machine and is ready to be run (possibly with some user-supplied default+-- 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 (..)++    -- * Configured program and related functions+  , ConfiguredProgram (..)+  , programPath+  , suppressOverrideArgs+  , ProgArg+  , ProgramLocation (..)+  , simpleConfiguredProgram+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.PackageDescription+import Distribution.Verbosity+import Distribution.Version++import qualified Data.Map as Map++-- | Represents a program which can be configured.+--+-- Note: rather than constructing this directly, start with 'simpleProgram' and+-- override any extra fields.+data Program = Program+  { programName :: String+  -- ^ The simple name of the program, eg. ghc+  , programFindLocation+      :: Verbosity+      -> ProgramSearchPath+      -> IO (Maybe (FilePath, [FilePath]))+  -- ^ A function to search for the program if its location was not+  -- specified by the user. Usually this will just be a call to+  -- 'findProgramOnSearchPath'.+  --+  -- It is supplied with the prevailing search path which will typically+  -- just be used as-is, but can be extended or ignored as needed.+  --+  -- For the purpose of change monitoring, in addition to the location+  -- where the program was found, it returns all the other places that+  -- were tried.+  , programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version)+  -- ^ Try to find the version of the program. For many programs this is+  -- not possible or is not necessary so it's OK to return Nothing.+  , programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram+  -- ^ A function to do any additional configuration after we have+  -- located the program (and perhaps identified its version). For example+  -- it could add args, or environment vars.+  , programNormaliseArgs :: Maybe Version -> PackageDescription -> [String] -> [String]+  -- ^ A function that filters any arguments that don't impact the output+  -- from a commandline. Used to limit the volatility of dependency hashes+  -- when using new-build.+  }++instance Show Program where+  show (Program name _ _ _ _) = "Program: " ++ name++type ProgArg = String++-- | 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]+--+-- 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]++data ProgramSearchPathEntry+  = -- | A specific dir+    ProgramSearchPathDir FilePath+  | -- | The system default+    ProgramSearchPathDefault+  deriving (Show, Eq, Generic)++instance Binary ProgramSearchPathEntry+instance Structured ProgramSearchPathEntry++-- | 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++-- | 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+  = -- | 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++-- | The full path of a configured program.+programPath :: ConfiguredProgram -> FilePath+programPath = locationPath . programLocation++-- | Suppress any extra arguments added by the user.+suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram+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+    }
+ src/Distribution/Simple/Register.hs view
@@ -0,0 +1,755 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Register+-- Copyright   :  Isaac Jones 2003-2004+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module deals with registering and unregistering packages. There are a+-- couple ways it can do this, one is to do it directly. Another is to generate+-- a script that can be run later to do it. The idea here being that the user+-- is shielded from the details of what command to use for package registration+-- for a particular compiler. In practice this aspect was not especially+-- popular so we also provide a way to simply generate the package registration+-- file which then must be manually passed to @ghc-pkg@. It is possible to+-- generate registration information for where the package is to be installed,+-- or alternatively to register the package in place in the build tree. The+-- latter is occasionally handy, and will become more important when we try to+-- build multi-package systems.+--+-- 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+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.LocalBuildInfo+import Distribution.Types.TargetInfo++import Distribution.Simple.BuildPaths+import Distribution.Simple.BuildTarget+import Distribution.Simple.LocalBuildInfo++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.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 qualified Distribution.Simple.Program.HcPkg as HcPkg+import Distribution.Simple.Program.Script+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Register+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Utils.MapAccum+import Distribution.Utils.Path+import Distribution.Verbosity as Verbosity+import Distribution.Version+import System.Directory+import System.FilePath (isAbsolute)++import 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 = 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)++  (_, 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)++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+    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 $ setupDistPref common+    verbosity = fromFlag $ setupVerbosity common+    mbWorkDir = flagToMaybe $ setupWorkingDir common++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))++    -- 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)+                (mbWorkDirLBI lbi)+                packageDbs+                ipi+                HcPkg.defaultRegisterOptions+  where+    modeGenerateRegFile = isJust (flagToMaybe (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))+    common = registerCommonFlags regFlags+    verbosity = fromFlag (setupVerbosity common)+    mbWorkDir = mbWorkDirLBI lbi++    writeRegistrationFileOrDirectory = do+      -- Handles overwriting both directory and file+      deletePackageDB regFile+      case ipis of+        [installedPkgInfo] -> do+          info verbosity ("Creating package registration file: " ++ regFile)+          writeUTF8File regFile (IPI.showInstalledPackageInfo installedPkgInfo)+        _ -> do+          info verbosity ("Creating package registration directory: " ++ regFile)+          createDirectory regFile+          let num_ipis = length ipis+              lpad m xs = replicate (m - length ys) '0' ++ ys+                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)++    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 mbWorkDir ipis packageDbs)++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+  inplaceDir <- absoluteWorkingDirLBI lbi+  installedPkgInfo <-+    if inplace+      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.++        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+              )++  return installedPkgInfo++-- | Compute the 'AbiHash' of a library that we built inplace.+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 "")+  where+    comp = compiler lbi+    lbi' =+      lbi+        { withPackageDB =+            withPackageDB lbi+              ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)]+        }++relocRegistrationInfo+  :: Verbosity+  -> PackageDescription+  -> Library+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> AbiHash+  -> PackageDB+  -> IO InstalledPackageInfo+relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb =+  case (compilerFlavor (compiler lbi)) of+    GHC -> do+      fs <- GHC.pkgRoot verbosity lbi packageDb+      return+        ( relocatableInstalledPackageInfo+            pkg+            abi_hash+            lib+            lbi+            clbi+            fs+        )+    _ -> dieWithException verbosity RelocRegistrationInfo++initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO ()+initPackageDB verbosity comp progdb 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 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 ()+    _ -> 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++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++-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the+-- provided command-line arguments to it.+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 name comp progdb f =+  case compilerFlavor comp of+    GHC -> f (GHC.hcPkgInfo progdb)+    GHCJS -> f (GHCJS.hcPkgInfo progdb)+    _ -> dieWithException verbosity $ WithHcPkg name++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 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+  -> 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+                mbWorkDir+                packageDbs+                installedPkgInfo+                HcPkg.defaultRegisterOptions+         in invocationAsSystemScript buildOS invocation+      scripts = map genScript ipis+      -- TODO: Do something more robust here+      regScript = unlines scripts++  let out_file = interpretSymbolicPath mbWorkDir regScriptFileName+  info verbosity ("Creating package registration script: " ++ out_file)+  writeUTF8File out_file regScript+  setFileExecutable out_file++regScriptFileName :: SymbolicPath Pkg File+regScriptFileName = case buildOS of+  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.+  -> PackageDescription+  -> AbiHash+  -> Library+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> 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 = 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 =+        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++    bi = libBuildInfo lib+    -- 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 (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)) && 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', [])+      -- 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'+          , dynlibdir installDirs : extraLibDirs'+          )+      | otherwise =+          (libdir installDirs : dynlibdir installDirs : extraLibDirs', [])+    expectLibraryComponent (Just attribute) = attribute+    expectLibraryComponent Nothing = (error "generalInstalledPackageInfo: Expected a library component, got something else.")++-- the compiler doesn't understand the dynamic-library-dirs field so we+-- add the dyn directory to the "normal" list in the library-dirs field++-- | Construct 'InstalledPackageInfo' for a library that is in place in the+-- build tree.+--+-- This function knows about the layout of in place packages.+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+  where+    i = interpretSymbolicPathAbsolute inplaceDir -- See Note [Symbolic paths] in Distribution.Utils.Path+    adjustRelativeIncludeDirs = concatMap $ \d ->+      [ 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 = 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 pkg abi_hash lib lbi clbi =+  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]+    bi = libBuildInfo lib+    installDirs = absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest++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+  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]+    bi = libBuildInfo lib++    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+      common = registerCommonFlags regFlags+      genScript = fromFlag (regGenScript regFlags)+      verbosity = fromFlag (setupVerbosity common)+      packageDb =+        fromFlagOrDefault+          (registrationPackageDB (withPackageDB lbi))+          (regPackageDB regFlags)+      mbWorkDir = mbWorkDirLBI lbi+      unreg hpi =+        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++unregScriptFileName :: FilePath+unregScriptFileName = case buildOS of+  Windows -> "unregister.bat"+  _ -> "unregister.sh"++internalPackageDBPath :: LocalBuildInfo -> SymbolicPath Pkg (Dir Dist) -> SymbolicPath Pkg (Dir PkgDB)+internalPackageDBPath lbi distPref =+  case compilerFlavor (compiler lbi) of+    UHC -> UHC.inplacePackageDbPath lbi+    _ -> distPref </> makeRelativePathEx "package.conf.inplace"
+ src/Distribution/Simple/Setup.hs view
@@ -0,0 +1,251 @@+{-# 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
@@ -0,0 +1,219 @@+{-# 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 build --enable-build-info@ command.+--+--+-- This format is intended for consumption by external tooling and should+-- therefore be rather stable. Moreover, this allows tooling users to avoid+-- linking against Cabal. This is an important advantage as direct API usage+-- tends to be rather fragile in the presence of user-initiated upgrades of+-- Cabal.+--+-- Below is an example of the output this module produces,+--+-- @+-- { "cabal-lib-version": "1.23.0.0",+--   "compiler": {+--     "flavour": "GHC",+--     "compiler-id": "ghc-7.10.2",+--     "path": "/usr/bin/ghc",+--   },+--   "components": [+--     { "type": "lib",+--       "name": "lib:Cabal",+--       "compiler-args":+--         ["-O", "-XHaskell98", "-Wall",+--          "-package-id", "parallel-3.2.0.6-b79c38c5c25fff77f3ea7271851879eb"]+--       "modules": ["Project.ModA", "Project.ModB", "Paths_project"],+--       "src-files": [],+--       "src-dirs": ["src"]+--     }+--   ]+-- }+-- @+--+-- 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.+--+-- The @components@ property gives a list of the Cabal 'Component's defined by+-- the package. Each has,+--+-- * @type@: the type of the component (one of @lib@, @exe@,+--   @test@, @bench@, or @flib@)+-- * @name@: a string serving to uniquely identify the component within the+--   package.+-- * @compiler-args@: the command-line arguments Cabal would pass to the+--   compiler to compile the component+-- * @modules@: the modules belonging to the component+-- * @src-dirs@: a list of directories where the modules might be found+-- * @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++import System.FilePath++import Distribution.Compat.Prelude+import Prelude ()++import qualified Distribution.Simple.GHC as GHC+import qualified Distribution.Simple.Program.GHC as GHC++import Distribution.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.Build (BuildFlags)+import Distribution.Simple.Utils (cabalVersion)+import Distribution.Text+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+  :: 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]+  -> ([String], Json)+  -- ^ Json representation of buildinfo alongside generated warnings+mkBuildInfo wdir pkg_descr lbi _flags compilerInfo targetsToBuild = (warnings, JsonObject buildInfoFields)+  where+    buildInfoFields = mkBuildInfo' (uncurry mkCompilerInfo compilerInfo) componentInfos+    componentInfosWithWarnings = map (mkComponentInfo wdir pkg_descr lbi . targetCLBI) targetsToBuild+    componentInfos = map snd componentInfosWithWarnings+    warnings = concatMap fst componentInfosWithWarnings++-- | 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+  ]++mkCompilerInfo :: ConfiguredProgram -> Compiler -> Json+mkCompilerInfo compilerProgram compilerInfo =+  JsonObject+    [ "flavour" .= JsonString (prettyShow $ compilerFlavor compilerInfo)+    , "compiler-id" .= JsonString (showCompilerId compilerInfo)+    , "path" .= JsonString (programPath compilerProgram)+    ]++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))+      ]+        <> 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.+getCompilerArgs+  :: BuildInfo+  -> LocalBuildInfo+  -> ComponentLocalBuildInfo+  -> ([String], [String])+getCompilerArgs bi lbi clbi =+  case compilerFlavor $ compiler lbi of+    GHC -> ([], ghcArgs)+    GHCJS -> ([], ghcArgs)+    c ->+      (+        [ "ShowBuildInfo.getCompilerArgs: Don't know how to get build "+            ++ " arguments for compiler "+            ++ show c+        ]+      , []+      )+  where+    -- This is absolutely awful+    ghcArgs =+      GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts+    baseOpts =+      GHC.componentGhcOptions normal lbi bi clbi $+        buildDir lbi
+ src/Distribution/Simple/SrcDist.hs view
@@ -0,0 +1,628 @@+{-# 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+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This handles the @sdist@ command. The module exports an 'sdist' action but+-- also some of the phases that make it up so that other tools can use just the+-- bits they need. In particular the preparation of the tree of files to go+-- into the source tarball is separated from actually building the source+-- tarball.+--+-- The 'createArchive' action uses the external @tar@ program and assumes that+-- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows.+-- The 'sdist' action now also does some distribution QA checks.+module Distribution.Simple.SrcDist+  ( -- * The top level action+    sdist++    -- ** Parts of 'sdist'+  , printPackageProblems+  , prepareTree+  , createArchive++    -- ** Snapshots+  , prepareSnapshotTree+  , snapshotPackage+  , snapshotVersion+  , dateToSnapshotNumber++    -- * Extracting the source files+  , listPackageSources+  , listPackageSourcesWithDie+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.ModuleName+import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Check hiding (doesFileExist)+import Distribution.Pretty+import Distribution.Simple.BuildPaths+import Distribution.Simple.Configure (findDistPrefOrDefault)+import Distribution.Simple.Errors+import Distribution.Simple.Flag+import Distribution.Simple.Glob (matchDirFileGlobWithDie)+import Distribution.Simple.PreProcess+import Distribution.Simple.Program+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.SDist+import Distribution.Simple.Utils+import Distribution.Utils.Path+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)++-- | 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 $ 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 mbWorkDir pkg pps+      traverse_ (hPutStrLn outHandle . getSymbolicPath) ordinary+      notice verbosity $ "List of package sources written to file '" ++ path ++ "'"+    NoFlag -> do+      -- do some QA+      printPackageProblems verbosity pkg++      date <- getCurrentTime+      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+            let targetDir = tmpDir </> tarBallName pkg'+            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 mbWorkDir pkg' targetDir pps+      when snapshot $+        overwriteSnapshotPackageDesc verbosity pkg' targetDir++    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+  -> 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 dieWithException cwd pkg_descr pps+  where+    pkg_descr = filterAutogenModules pkg_descr0++-- | A variant of 'listPackageSources' with configurable 'die'.+--+-- /Note:/ may still 'die' directly. For example on missing include file.+--+-- Since @3.4.0.0+listPackageSourcesWithDie+  :: 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+  where+    pkg_descr = filterAutogenModules pkg_descr0++listPackageSources'+  :: 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]+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 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)+    withAllBenchmark action = traverse action (benchmarks pkg_descr)++-- | 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)+  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"++-- | 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"+          ]++-- | Find the main executable file.+findMainExeFile+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -- ^ working directory+  -> BuildInfo+  -> [PPSuffixHandler]+  -> RelativePath Source File+  -- ^ main-is+  -> IO (SymbolicPath Pkg File)+findMainExeFile verbosity cwd exeBi pps mainPath = do+  ppFile <-+    findFileCwdWithExtension+      cwd+      (ppSuffixes pps)+      (hsSourceDirs exeBi)+      (dropExtensionsSymbolicPath mainPath)+  case ppFile of+    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+  -> Maybe (SymbolicPath CWD (Dir Pkg))+  -> BuildInfo+  -> [PPSuffixHandler]+  -> RelativePath Source File+  -> IO (SymbolicPath Pkg File)+findModDefFile verbosity cwd flibBi _pps modDefPath =+  findFileCwd verbosity cwd (sameDirectory : hsSourceDirs flibBi) modDefPath++-- | Given a list of include paths, try to find the include file named+-- @f@. Return the name of the file and the full path, or exit with error if+-- there's no such file.+findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath)+findIncludeFile verbosity _ [] f = dieWithException verbosity $ NoIncludeFileFound f+findIncludeFile verbosity cwd (d : ds) f = do+  let path = d </> f+  b <- doesFileExist (cwd </> path)+  if b then return (f, path) else findIncludeFile verbosity cwd ds f++-- | 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+  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)+        }+    pathsModule = autogenPathsModuleName pkg_descr0+    packageInfoModule = autogenPackageInfoModuleName pkg_descr0+    filterFunction bi = \mn ->+      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+  -> 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 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 pkg targetDir = do+  -- 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+      | 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++-- | 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++-- | 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+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)+  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]+  return tarBallFilePath++-- | Given a buildinfo, return the names of all source files.+allSourcesBuildInfo+  :: 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 ++ 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 "."+  let pureChecks = checkConfiguredPackage pkg_descr+      (errors, warnings) = partition isHackageDistError (pureChecks ++ ioChecks)+  unless (null errors) $+    notice verbosity $+      "Distribution quality errors:\n"+        ++ unlines (map ppPackageCheck errors)+  unless (null 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."++------------------------------------------------------------++-- | 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)+    }+  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)}
+ src/Distribution/Simple/Test.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.Test+-- Copyright   :  Thomas Tuegel 2010+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- 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++import Distribution.Compat.Prelude+import Prelude ()++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 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 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+  )++-- | 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]}++      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)+                      }+                , logFile = ""+                }++  unless (PD.hasTests pkg_descr) $ do+    notice verbosity "Package has no test suites."+    exitSuccess++  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 ->+                  dieWithException verbosity $ TestNameDisabled tName+              | otherwise -> dieWithException verbosity $ NoSuchTest tName++  createDirectoryIfMissing True $ i testLogDir++  -- Delete ordinary files from test log directory.+  getDirectoryContents (i testLogDir)+    >>= filterM doesFileExist . map (i testLogDir </>)+    >>= traverse_ removeFile++  -- 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}++  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++  when (LBI.testCoverage lbi) $+    markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr $+      map (fst . fst) testsToRun++  unless allOk exitFailure++packageLogPath+  :: PathTemplate+  -> PD.PackageDescription+  -> LBI.LocalBuildInfo+  -> FilePath+packageLogPath template pkg_descr lbi =+  fromPathTemplate $ substPathTemplate env template+  where+    env =+      initialPathTemplateEnv+        (PD.package pkg_descr)+        (LBI.localUnitId lbi)+        (compilerInfo $ LBI.compiler lbi)+        (LBI.hostPlatform lbi)
+ src/Distribution/Simple/Test/ExeV10.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Distribution.Simple.Test.ExeV10+  ( runTest+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import qualified Distribution.PackageDescription as PD+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+  ( 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 qualified Distribution.Types.LocalBuildInfo as LBI+  ( LocalBuildInfo (..)+  , localUnitId+  , testCoverage+  )+import Distribution.Types.UnqualComponentName+import Distribution.Verbosity++import Distribution.Utils.Path++import qualified Data.ByteString.Lazy as LBS+import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI, packageRoot)+import System.Directory+  ( createDirectoryIfMissing+  , doesDirectoryExist+  , doesFileExist+  , removeDirectoryRecursive+  )+import System.IO (stderr, stdout)+import System.Process (createPipe)++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 =+        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_++  -- Create directory for HPC files.+  createDirectoryIfMissing True tixDir_++  -- 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'))++  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++  -- Output logger+  (wOut, wErr, getLogText) <- case details of+    Direct -> return (stdout, stderr, return LBS.empty)+    _ -> do+      (rOut, wOut) <- createPipe++      return $ (,,) wOut wOut $ do+        -- Read test executables' output+        logText <- LBS.hGetContents rOut++        -- '--show-details=streaming': print the log output in another thread+        when (details == Streaming) $ LBS.putStr logText++        -- drain the output.+        evaluate (force logText)++  let mbWorkDir =+        interpretSymbolicPathCWD+          <$> flagToMaybe (setupWorkingDir (testCommonFlags flags))++  (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++  -- Write summary notice to log file indicating start of test suite+  appendFile (logFile suiteLog) $ summarizeSuiteStart testName'++  -- Append contents of temporary log file to the final human-+  -- readable log file+  LBS.appendFile (logFile suiteLog) logText++  -- Write end-of-suite summary notice to log file+  appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog++  -- Show the contents of the human-readable log file on the terminal+  -- if there is a failure and/or detailed output is requested+  let whenPrinting =+        when $+          ( details == Always+              || details == Failures && not (suitePassed $ testLogs suiteLog)+          )+            -- verbosity overrides show-details+            && verbosity >= normal+  whenPrinting $ do+    LBS.putStr logText+    putChar '\n'++  -- Write summary notice to terminal indicating end of test suite+  notice verbosity $ summarizeSuiteFinish suiteLog++  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++    markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr [suite]++  return suiteLog+  where+    i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path+    commonFlags = testCommonFlags flags++    testName' = unUnqualComponentName $ PD.testName suite++    distPref = fromFlag $ setupDistPref commonFlags+    verbosity = fromFlag $ setupVerbosity commonFlags+    details = fromFlag $ testShowDetails flags+    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 =+                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 pkg_descr lbi suite 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)]
+ src/Distribution/Simple/Test/LibV09.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Distribution.Simple.Test.LibV09+  ( runTest+  -- Test stub+  , simpleTestStub+  , stubFilePath+  , stubMain+  , stubName+  , stubWriteLog+  , writeSimpleTestStub+  ) where++import Distribution.Compat.Prelude+import Distribution.Types.UnqualComponentName+import Prelude ()++import Distribution.Compat.Internal.TempFile+import Distribution.Compat.Process (proc)+import Distribution.ModuleName+import qualified Distribution.PackageDescription as PD+import Distribution.Pretty+import Distribution.Simple.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 Distribution.Simple.Program.Db+import Distribution.Simple.Program.Find+import Distribution.Simple.Program.Run+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Test+import Distribution.Simple.Test.Log+import Distribution.Simple.Utils+import Distribution.System+import Distribution.TestSuite+import qualified Distribution.Types.LocalBuildInfo as LBI+import Distribution.Utils.Path+import Distribution.Verbosity++import qualified Control.Exception as CE+import qualified Data.ByteString.Lazy as LBS+import System.Directory+  ( canonicalizePath+  , createDirectoryIfMissing+  , doesDirectoryExist+  , doesFileExist+  , getCurrentDirectory+  , removeDirectoryRecursive+  , removeFile+  , setCurrentDirectory+  )+import System.IO (hClose, hPutStr)+import qualified System.Process as Process++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 mbWorkDir = LBI.mbWorkDirLBI lbi++  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++  -- Remove old .tix files if appropriate.+  unless (fromFlag $ testKeepTix flags) $ do+    exists' <- doesDirectoryExist tDir+    when exists' $ removeDirectoryRecursive tDir++  -- Create directory for HPC files.+  createDirectoryIfMissing True tDir++  -- Write summary notices indicating start of test suite+  notice verbosity $ summarizeSuiteStart testName'++  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+    let opts = map (testOption pkg_descr lbi suite) $ testOptions flags+        tixFile = i $ tixFilePath distPref way testName'++    shellEnv <-+      getFullEnvironment+        ( [("PATH", Just newPath)]+            ++ [("HPCTIXFILE", Just tixFile) | isCoverageEnabled]+            ++ envOverrides+        )+    -- Add (DY)LD_LIBRARY_PATH if needed+    shellEnv' <-+      if LBI.withDynExe lbi+        then do+          let (Platform _ os) = LBI.hostPlatform lbi+          paths <- LBI.depLibraryPaths True False lbi clbi+          cpath <- canonicalizePath $ 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++        -- Append contents of temporary log file to the final human-+        -- readable log file+        logText <- LBS.hGetContents rOut+        -- Force the IO manager to drain the test output pipe+        _ <- evaluate (force logText)+        return logText+    unless (exitcode == ExitSuccess) $+      debug verbosity $+        cmd ++ " returned " ++ show exitcode++    -- Generate final log file name+    let finalLogName l =+          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'++    LBS.appendFile (logFile suiteLog) logText++    -- Write end-of-suite summary notice to log file+    appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog++    -- Show the contents of the human-readable log file on the terminal+    -- if there is a failure and/or detailed output is requested+    let details = fromFlag $ testShowDetails flags+        whenPrinting =+          when $+            (details > Never)+              && (not (suitePassed $ testLogs suiteLog) || details == Always)+              && verbosity >= normal+    whenPrinting $ do+      LBS.putStr logText+      putChar '\n'++    return suiteLog++  -- Write summary notice to terminal indicating end of test suite+  notice verbosity $ summarizeSuiteFinish suiteLog++  when isCoverageEnabled $ 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++    markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr [suite]++  return suiteLog+  where+    i = LBI.interpretSymbolicPathLBI lbi+    common = testCommonFlags flags+    testName' = unUnqualComponentName $ PD.testName suite++    deleteIfExists file = do+      exists <- doesFileExist file+      when exists $ removeFile file++    testLogDir = distPref </> makeRelativePathEx "test"+    openCabalTemp = do+      (f, h) <- openTempFile (i testLogDir) $ "cabal-test-" <.> "log"+      hClose h >> return f++    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 pkg_descr lbi suite 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)]++-- Test 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 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++-- | Source code for library test suite stub executable+simpleTestStub :: ModuleName -> String+simpleTestStub m =+  unlines+    [ "module Main ( main ) where"+    , "import Distribution.Simple.Test.LibV09 ( stubMain )"+    , "import " ++ show (pretty m) ++ " ( tests )"+    , "main :: IO ()"+    , "main = stubMain tests"+    ]++-- | Main function for test stubs. Once, it was written directly into the stub,+-- but minimizing the amount of code actually in the stub maximizes the number+-- 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+  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+            }++-- | 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+-- the child of a Cabal process during @.\/setup test@.  A 'TestSuiteLog',+-- provided by Cabal, is read from the standard input; it supplies the name of+-- the test suite and the location of the machine-readable test suite log file.+-- Human-readable log information is written to the standard output for capture+-- by the calling Cabal process.+stubRunTests :: [Test] -> IO TestLogs+stubRunTests tests = do+  logs <- traverse stubRunTests' tests+  return $ GroupLogs "Default" logs+  where+    stubRunTests' (Test t) = do+      l <- run t >>= finish+      summarizeTest normal Always l+      return l+      where+        finish (Finished 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' (ExtraOptions _ t) = stubRunTests' t+    maybeDefaultOption 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
+ src/Distribution/Simple/Test/Log.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Distribution.Simple.Test.Log+  ( PackageLog (..)+  , TestLogs (..)+  , TestSuiteLog (..)+  , countTestResults+  , localPackageLog+  , summarizePackage+  , summarizeSuiteFinish+  , summarizeSuiteStart+  , summarizeTest+  , suiteError+  , suiteFailed+  , suitePassed+  , testSuiteLogPath+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Package+import qualified Distribution.PackageDescription as PD+import Distribution.Pretty+import Distribution.Simple.Compiler+import Distribution.Simple.InstallDirs+import qualified Distribution.Simple.LocalBuildInfo as LBI+import Distribution.Simple.Setup.Test (TestShowDetails (Always, Never))+import Distribution.Simple.Utils+import Distribution.System+import Distribution.TestSuite+import Distribution.Types.UnqualComponentName+import Distribution.Verbosity++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)++-- | A 'PackageLog' with package and platform information specified.+localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog+localPackageLog pkg_descr lbi =+  PackageLog+    { package = PD.package pkg_descr+    , compiler = compilerId $ LBI.compiler lbi+    , platform = LBI.hostPlatform lbi+    , testSuites = []+    }++-- | 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)++data TestLogs+  = 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 = 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) (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++-- | From a 'TestSuiteLog', determine if the test suite failed.+suiteFailed :: TestLogs -> Bool+suiteFailed l =+  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++resultString :: TestLogs -> String+resultString l+  | suiteError l = "error"+  | suiteFailed l = "fail"+  | otherwise = "pass"++testSuiteLogPath+  :: PathTemplate+  -> PD.PackageDescription+  -> LBI.LocalBuildInfo+  -> String+  -- ^ test suite name+  -> TestLogs+  -- ^ test suite results+  -> FilePath+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)+           ]++-- | 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+  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 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++-- | 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+    [ "Test suite " ++ prettyShow (testSuiteName testLog) ++ ": " ++ resStr+    , "Test suite logged to: " ++ logFile testLog+    ]+  where+    resStr = map toUpper (resultString $ testLogs testLog)++summarizeSuiteStart :: String -> String+summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n"
+ src/Distribution/Simple/UHC.hs view
@@ -0,0 +1,377 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.UHC+-- Copyright   :  Andres Loeh 2009+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module contains most of the UHC-specific code for configuring, building+-- and installing packages.+--+-- 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+  ) where++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.System+import Distribution.Types.MungedPackageId+import Distribution.Utils.Path+import Distribution.Verbosity+import Distribution.Version+import Language.Haskell.Extension++import qualified Data.Map as Map (empty)+import System.Directory+import System.FilePath (pathSeparator)++-- -----------------------------------------------------------------------------+-- Configuring++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)++  let comp =+        Compiler+          { compilerId = CompilerId UHC uhcVersion+          , compilerAbiTag = NoAbiTag+          , compilerCompat = []+          , compilerLanguages = uhcLanguages+          , compilerExtensions = uhcLanguageExtensions+          , compilerProperties = Map.empty+          }+      compPlatform = Nothing+  return (comp, compPlatform, progdb')++uhcLanguages :: [(Language, CompilerFlag)]+uhcLanguages = [(Haskell98, "")]++-- | The flags for the supported extensions.+uhcLanguageExtensions :: [(Extension, Maybe CompilerFlag)]+uhcLanguageExtensions =+  let doFlag (f, (enable, disable)) =+        [ (EnableExtension f, enable)+        , (DisableExtension f, disable)+        ]+      alwaysOn = (Nothing, Nothing {- wrong -})+   in concatMap+        doFlag+        [ (CPP, (Just "--cpp", Nothing {- wrong -}))+        , (PolymorphicComponents, alwaysOn)+        , (ExistentialQuantification, alwaysOn)+        , (ForeignFunctionInterface, alwaysOn)+        , (UndecidableInstances, alwaysOn)+        , (MultiParamTypeClasses, alwaysOn)+        , (Rank2Types, alwaysOn)+        , (PatternSignatures, alwaysOn)+        , (EmptyDataDecls, alwaysOn)+        , (ImplicitPrelude, (Nothing, Just "--no-prelude" {- wrong -}))+        , (TypeOperators, alwaysOn)+        , (OverlappingInstances, alwaysOn)+        , (FlexibleInstances, alwaysOn)+        ]++getInstalledPackages+  :: Verbosity+  -> Compiler+  -> 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 mbWorkDir) packagedbs)+  -- putStrLn $ "pkgdirs: " ++ show 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+  -- 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+  where+    trimEnd = dropWhileEnd isSpace++getUserPackageDir :: IO FilePath+getUserPackageDir = do+  homeDir <- getHomeDirectory+  return $ homeDir </> ".cabal" </> "lib" -- TODO: determine in some other way++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 -> [interpretSymbolicPath mbWorkDir path]++-- | Hack to add version numbers to UHC-built-in packages. This should sooner or+-- later be fixed on the UHC side.+addBuiltinVersions :: String -> String+{-+addBuiltinVersions "uhcbase"  = "uhcbase-1.0"+addBuiltinVersions "base"  = "base-3.0"+addBuiltinVersions "array" = "array-0.2"+-}+addBuiltinVersions xs = xs++-- | Name of the installed package config file.+installedPkgConfig :: String+installedPkgConfig = "installed-pkg-config"++-- | Check if a certain dir contains a valid package. Currently, we are+-- 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)++parsePackage :: String -> [PackageId]+parsePackage = toList . simpleParsec++-- | Create a trivial package info from a directory name.+mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo+mkInstalledPackageInfo p =+  emptyInstalledPackageInfo+    { installedUnitId = mkLegacyUnitId p+    , sourcePackageId = p+    }++-- -----------------------------------------------------------------------------+-- Building++buildLib+  :: Verbosity+  -> PackageDescription+  -> LocalBuildInfo+  -> Library+  -> ComponentLocalBuildInfo+  -> IO ()+buildLib verbosity pkg_descr lbi lib clbi = do+  systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)+  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 _pkg_descr lbi exe clbi = do+  systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)+  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+  -> 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" ++ 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 Nothing) db)++-- -----------------------------------------------------------------------------+-- Installation++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++-- currently hard-coded UHC code generator and variant to use+uhcTarget, uhcTargetVariant :: String+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++-- -----------------------------------------------------------------------------+-- Registering++registerPackage+  :: Verbosity+  -> Maybe (SymbolicPath CWD (Dir from))+  -> Compiler+  -> ProgramDb+  -> PackageDBStackS from+  -> InstalledPackageInfo+  -> IO ()+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+    compilerid = compilerId comp++inplacePackageDbPath :: LocalBuildInfo -> SymbolicPath Pkg (Dir PkgDB)+inplacePackageDbPath lbi = coerceSymbolicPath $ buildDir lbi
+ src/Distribution/Simple/UserHooks.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.Simple.UserHooks+-- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This defines the API that @Setup.hs@ scripts can use to customise the way+-- the build works. This module just defines the 'UserHooks' type. The+-- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@+-- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big+-- record of functions. There are 3 for each action, a pre, post and the action+-- itself. There are few other miscellaneous hooks, ones to extend the set of+-- programs and preprocessors and one to override the function used to read the+-- @.cabal@ file.+--+-- This hooks type is widely agreed to not be the right solution. Partly this+-- is because changes to it usually break custom @Setup.hs@ files and yet many+-- internal code changes do require changes to the hooks. For example we cannot+-- 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+  ) where++import Distribution.Compat.Prelude hiding (getContents, putStr)+import Prelude ()++import Distribution.PackageDescription+import Distribution.Simple.Command+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PreProcess+import Distribution.Simple.Program+import Distribution.Simple.Setup++type Args = [String]++-- | Hooks allow authors to add specific functionality before and after a+-- command is run, and also to specify additional preprocessors.+--+-- * 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+  { 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.+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+    }+  where+    rn args _ = noExtraFlags args >> return emptyHookedBuildInfo+    rn' _ _ = return emptyHookedBuildInfo+    ru _ _ _ _ = return ()
+ src/Distribution/Simple/Utils.hs view
@@ -0,0 +1,2072 @@+{-# LANGUAGE CPP #-}+{-# 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/TestSuite.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-- |+-- Module      :  Distribution.TestSuite+-- Copyright   :  Thomas Tuegel 2010+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- 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++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.+  }++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+  }+  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+  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++type Options = [(String, String)]++data Progress+  = Finished Result+  | Progress String (IO Progress)++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}
+ src/Distribution/Types/AnnotatedId.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DeriveFunctor #-}++module Distribution.Types.AnnotatedId+  ( AnnotatedId (..)+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Package+import Distribution.Types.ComponentName++-- | An 'AnnotatedId' is a 'ComponentId', 'UnitId', etc.+-- which is annotated with some other useful information+-- that is useful for printing to users, etc.+--+-- Invariant: if ann_id x == ann_id y, then ann_pid x == ann_pid y+-- and ann_cname x == ann_cname y+data AnnotatedId id = AnnotatedId+  { ann_pid :: PackageId+  , ann_cname :: ComponentName+  , ann_id :: id+  }+  deriving (Show, Functor)++instance Eq id => Eq (AnnotatedId id) where+  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)++instance Package (AnnotatedId id) where+  packageId = ann_pid
+ src/Distribution/Types/ComponentInclude.hs view
@@ -0,0 +1,32 @@+module Distribution.Types.ComponentInclude+  ( ComponentInclude (..)+  , ci_id+  , ci_pkgid+  , ci_cname+  ) where++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+  , 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++ci_pkgid :: ComponentInclude id rn -> PackageId+ci_pkgid = ann_pid . ci_ann_id++-- | This should always return 'CLibName' or 'CSubLibName'+ci_cname :: ComponentInclude id rn -> ComponentName+ci_cname = ann_cname . ci_ann_id
+ src/Distribution/Types/ComponentLocalBuildInfo.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}++module Distribution.Types.ComponentLocalBuildInfo+  ( ComponentLocalBuildInfo (..)+  , componentIsIndefinite+  , maybeComponentInstantiatedWith+  , maybeComponentCompatPackageKey+  , maybeComponentExposedModules+  ) where++import Distribution.Compat.Prelude+import Distribution.ModuleName+import Prelude ()++import Distribution.Backpack+import Distribution.Compat.Graph+import Distribution.Types.ComponentId+import Distribution.Types.ComponentName+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+      { 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++componentIsIndefinite :: ComponentLocalBuildInfo -> Bool+componentIsIndefinite LibComponentLocalBuildInfo{componentIsIndefinite_ = b} = b+componentIsIndefinite _ = False++maybeComponentInstantiatedWith :: ComponentLocalBuildInfo -> Maybe [(ModuleName, OpenModule)]+maybeComponentInstantiatedWith+  LibComponentLocalBuildInfo{componentInstantiatedWith = insts} = Just insts+maybeComponentInstantiatedWith _ = Nothing++maybeComponentCompatPackageKey :: ComponentLocalBuildInfo -> Maybe String+maybeComponentCompatPackageKey+  LibComponentLocalBuildInfo{componentCompatPackageKey = key} = Just key+maybeComponentCompatPackageKey _ = Nothing++maybeComponentExposedModules :: ComponentLocalBuildInfo -> Maybe [Installed.ExposedModule]+maybeComponentExposedModules+  LibComponentLocalBuildInfo{componentExposedModules = exposed} = Just exposed+maybeComponentExposedModules _ = Nothing
+ src/Distribution/Types/DumpBuildInfo.hs view
@@ -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/GivenComponent.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Types.GivenComponent+  ( GivenComponent (..)+  , PromisedComponent (..)+  ) where++import Distribution.Compat.Prelude++import Distribution.Types.ComponentId+import Distribution.Types.LibraryName+import Distribution.Types.PackageId+import Distribution.Types.PackageName++-- | A 'GivenComponent' represents a library depended on and explicitly+-- specified by the user/client with @--dependency@+--+-- 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)++instance Binary GivenComponent+instance Structured GivenComponent++-- | A 'PromisedComponent' represents a promised library depended on and explicitly+-- specified by the user/client with @--promised-dependency@+--+-- It enables Cabal to know which 'ComponentId' to associate with a library+--+-- @since 3.14.0.0+data PromisedComponent = PromisedComponent+  { promisedComponentPackage :: PackageId+  , promisedComponentName :: LibraryName -- --dependency is for libraries+  -- only, not for any component+  , promisedComponentId :: ComponentId+  }+  deriving (Generic, Read, Show, Eq)++instance Binary PromisedComponent+instance Structured PromisedComponent
+ src/Distribution/Types/LocalBuildConfig.hs view
@@ -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
@@ -0,0 +1,502 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}++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+  , 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.++  , 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+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Types.ComponentId+import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.GivenComponent+import qualified Distribution.Types.LocalBuildConfig as LBC+import Distribution.Types.PackageDescription+import Distribution.Types.PackageId+import Distribution.Types.TargetInfo+import Distribution.Types.UnitId++import Distribution.Utils.Path++import Distribution.PackageDescription+import Distribution.Pretty+import Distribution.Simple.BuildWay+import Distribution.Simple.Compiler+import Distribution.Simple.Flag+import Distribution.Simple.InstallDirs hiding+  ( absoluteInstallDirs+  , prefixRelativeInstallDirs+  , substPathTemplate+  )+import Distribution.Simple.PackageIndex+import Distribution.Simple.Program+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Config+import Distribution.System++import qualified Data.Map as Map+import Distribution.Compat.Graph (Graph)+import qualified Distribution.Compat.Graph as Graph++import qualified System.FilePath as FilePath (takeDirectory)++-- | Data cached after configuration step.  See also+-- 'Distribution.Simple.Setup.ConfigFlags'.+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!++-- | Extract the 'ComponentId' from the public library component of a+-- 'LocalBuildInfo' if it exists, or make a fake component ID based+-- on the package ID.+localComponentId :: LocalBuildInfo -> ComponentId+localComponentId 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 (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++-- | 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)++-- | 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)+    }++-- | 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@(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@(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 (LocalBuildInfo{componentNameMap = comps}) cname =+  case Map.lookup cname comps of+    Just clbis -> clbis+    Nothing -> []++-- TODO: Maybe cache topsort (Graph can do this)++-- | Return the list of default 'TargetInfo's associated with a+-- configured package, in the order they need to be built.+-- Has a prime because it takes a 'PackageDescription' argument+-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.+allTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [TargetInfo]+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]++-- | 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@(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))++-- | Execute @f@ for every 'TargetInfo' needed to build @uid@s, respecting+-- the build dependency order.+-- 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]++-- | Is coverage enabled for test suites? In practice, this requires library+-- and executable profiling to be enabled.+testCoverage :: LocalBuildInfo -> Bool+testCoverage (LocalBuildInfo{exeCoverage = exes, libCoverage = libs}) =+  exes && libs++-- | Returns a list of ways, in the order which they should be built, and the+-- way we build executable and foreign library components.+--+-- Ideally all this info should be fixed at configure time and not dependent on+-- additional info but `LocalBuildInfo` is per package (not per component) so it's+-- currently not possible to configure components to be built in certain ways.+buildWays :: LocalBuildInfo -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)+buildWays lbi =+  let+    -- enable-library-profiling (enable (static profiling way)) .p_o+    -- enable-shared (enabled dynamic way)  .dyn_o+    -- enable-profiling-shared (enable dynamic profilng way) .p_dyn_o+    -- enable-library-vanilla (enable vanilla way) .o+    --+    -- enable-executable-dynamic => build dynamic executables+    -- => --enable-profiling + --enable-executable-dynamic => build dynamic profiled executables+    -- => --enable-profiling => build vanilla profiled executables++    wantedLibWays is_indef =+      [ProfDynWay | withProfLibShared lbi && not is_indef]+        <> [ProfWay | withProfLib lbi]+        -- I don't see why we shouldn't build with dynamic-- indefinite components.+        <> [DynWay | withSharedLib lbi && not is_indef]+        -- MP: Ideally we should have `BuildOptions` on a per component basis, in+        -- which case this `is_indef` check could be moved to configure time.+        <> [StaticWay | withVanillaLib lbi || withStaticLib lbi]++    wantedFLibWay is_dyn_flib =+      case (is_dyn_flib, withProfExe lbi) of+        (True, True) -> ProfDynWay+        (False, True) -> ProfWay+        (True, False) -> DynWay+        (False, False) -> StaticWay++    wantedExeWay =+      case (withDynExe lbi, withProfExe lbi) of+        (True, True) -> ProfDynWay+        (True, False) -> DynWay+        (False, True) -> ProfWay+        (False, False) -> StaticWay+   in+    (wantedLibWays, wantedFLibWay, wantedExeWay)++-------------------------------------------------------------------------------+-- Stub functions to prevent someone from accidentally defining them++{-# 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@(LocalBuildInfo{localPkgDescr = pkg}) =+  componentNameTargets' pkg lbi+unitIdTarget :: LocalBuildInfo -> UnitId -> Maybe TargetInfo+unitIdTarget lbi@(LocalBuildInfo{localPkgDescr = pkg}) =+  unitIdTarget' pkg lbi+allTargetsInBuildOrder :: LocalBuildInfo -> [TargetInfo]+allTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) =+  allTargetsInBuildOrder' pkg lbi+withAllTargetsInBuildOrder :: LocalBuildInfo -> (TargetInfo -> IO ()) -> IO ()+withAllTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) =+  withAllTargetsInBuildOrder' pkg lbi+neededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> [TargetInfo]+neededTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) =+  neededTargetsInBuildOrder' pkg lbi+withNeededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO ()+withNeededTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) =+  withNeededTargetsInBuildOrder' pkg lbi
+ src/Distribution/Types/PackageName/Magic.hs view
@@ -0,0 +1,24 @@+-- | Magic 'PackageName's.+--+-- @since 3.0.0.0+module Distribution.Types.PackageName.Magic where++import Distribution.Types.PackageId+import Distribution.Types.PackageName+import Distribution.Types.Version++-- | Used as a placeholder in "Distribution.Backpack.ReadyComponent"+nonExistentPackageThisIsCabalBug :: PackageName+nonExistentPackageThisIsCabalBug = mkPackageName "nonexistent-package-this-is-a-cabal-bug"++-- | 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+fakePackageId = PackageIdentifier fakePackageName version0
+ 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/TargetInfo.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}++module Distribution.Types.TargetInfo+  ( TargetInfo (..)+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Types.Component+import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.UnitId++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)+  }+  deriving (Generic, Show)++instance Binary TargetInfo+instance Structured TargetInfo++instance IsNode TargetInfo where+  type Key TargetInfo = UnitId+  nodeKey = nodeKey . targetCLBI+  nodeNeighbors = nodeNeighbors . targetCLBI
+ src/Distribution/Utils/IOData.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++-- | @since 2.2.0+module Distribution.Utils.IOData+  ( -- * '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 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+  = -- | 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 (IODataBinary lbs) k = k IODataModeBinary lbs++-- | Test whether 'IOData' is empty+null :: IOData -> Bool+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++-- | @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++  toIOData :: mode -> IOData+  iodataMode :: IODataMode mode++-- | 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++instance a ~ Char => KnownIODataMode [a] where+  hGetIODataContents h = do+    System.IO.hSetBinaryMode h False+    System.IO.hGetContents h++  toIOData = IODataText+  iodataMode = IODataModeText++instance KnownIODataMode LBS.ByteString where+  hGetIODataContents h = do+    System.IO.hSetBinaryMode h True+    LBS.hGetContents h++  toIOData = IODataBinary+  iodataMode = IODataModeBinary++-- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose'+--+-- This is the dual operation to 'hGetIODataContents',+-- and consequently the handle is closed with `hClose`.+--+-- /Note:/ this performs lazy-IO.+--+-- @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+hPutContents h (IODataBinary c) = do+  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
@@ -0,0 +1,90 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Rank2Types #-}++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 Text.PrettyPrint++type CtxMsg = Doc+type LogMsg = Doc+type ErrMsg = Doc++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}++instance Functor LogProgress where+  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++instance Monad LogProgress where+  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)+  where+    env =+      LogEnv+        { le_verbosity = verbosity+        , le_context = []+        }+    step_fn :: LogMsg -> IO a -> IO a+    step_fn doc go = do+      putStrLn (render doc)+      go+    fail_fn :: Doc -> IO a+    fail_fn doc = do+      dieNoWrap verbosity (render doc)++-- | Output a warning trace message in 'LogProgress'.+warnProgress :: Doc -> LogProgress ()+warnProgress s = LogProgress $ \env ->+  when (le_verbosity env >= normal) $+    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++-- | 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)++-- | Format a message with context. (Something simple for now.)+formatMsg :: [CtxMsg] -> Doc -> Doc+formatMsg ctx doc = doc $$ vcat ctx++-- | Add a message to the error/warning context.+addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a+addProgressCtx s (LogProgress m) = LogProgress $ \env ->+  m env{le_context = s : le_context env}
+ src/Distribution/Utils/MapAccum.hs view
@@ -0,0 +1,26 @@+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)}++instance Functor m => Functor (StateM s m) where+  fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s)++instance Monad m => Applicative (StateM s m) where+  pure x = StateM $ \s -> return (s, x)+  StateM f <*> StateM x = StateM $ \s -> do+    (s', f') <- f s+    (s'', x') <- x s'+    return (s'', f' x')++-- | Monadic variant of 'mapAccumL'.+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
@@ -0,0 +1,104 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Distribution.Utils.NubList+  ( NubList -- opaque+  , toNubList -- smart constructor+  , fromNubList+  , overNubList+  , NubListR+  , toNubListR+  , fromNubListR+  , overNubListR+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Simple.Utils++import qualified Text.Read as R++-- | NubList : A de-duplicated list that maintains the original order.+newtype NubList a = NubList {fromNubList :: [a]}+  deriving (Eq, Generic)++-- NubList assumes that nub retains the list order while removing duplicate+-- elements (keeping the first occurrence). Documentation for "Data.List.nub"+-- does not specifically state that ordering is maintained so we will add a test+-- for that to the test suite.++-- | Smart constructor for the NubList type.+toNubList :: Ord a => [a] -> NubList a+toNubList list = NubList $ ordNub list++-- | Lift a function over lists to a function over NubLists.+overNubList :: Ord a => ([a] -> [a]) -> NubList a -> NubList a+overNubList f (NubList list) = toNubList . f $ list++-- | Monoid operations on NubLists.+-- For a valid Monoid instance we need to satisfy the required monoid laws;+-- identity, associativity and closure.+--+-- Identity : by inspection:+--      mempty `mappend` NubList xs == NubList xs `mappend` mempty+--+-- Associativity : by inspection:+--      (NubList xs `mappend` NubList ys) `mappend` NubList zs+--      == NubList xs `mappend` (NubList ys `mappend` NubList zs)+--+-- 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 = (<>)++instance Ord a => Semigroup (NubList a) where+  (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys++instance Show a => Show (NubList a) where+  show (NubList list) = show list++instance (Ord a, Read a) => Read (NubList a) where+  readPrec = readNubList toNubList++-- | Helper used by NubList/NubListR's Read instances.+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++instance Structured a => Structured (NubList a)++-- | NubListR : A right-biased version of 'NubList'. That is @toNubListR+-- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@,+-- unlike the normal 'NubList', which is left-biased. Built on top of+-- 'ordNubRight' and 'listUnionRight'.+newtype NubListR a = NubListR {fromNubListR :: [a]}+  deriving (Eq)++-- | Smart constructor for the NubListR type.+toNubListR :: Ord a => [a] -> NubListR a+toNubListR list = NubListR $ ordNubRight list++-- | Lift a function over lists to a function over NubListRs.+overNubListR :: Ord a => ([a] -> [a]) -> NubListR a -> NubListR a+overNubListR f (NubListR list) = toNubListR . f $ list++instance Ord a => Monoid (NubListR a) where+  mempty = NubListR []+  mappend = (<>)++instance Ord a => Semigroup (NubListR a) where+  (NubListR xs) <> (NubListR ys) = NubListR $ xs `listUnionRight` ys++instance Show a => Show (NubListR a) where+  show (NubListR list) = show list++instance (Ord a, Read a) => Read (NubListR a) where+  readPrec = readNubList toNubListR
+ src/Distribution/Utils/Progress.hs view
@@ -0,0 +1,69 @@+{-# 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++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+-- result which may be used to indicate progress and\/or logging messages.+--+-- 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+  deriving (Functor)++-- | Emit a step and then continue.+stepProgress :: step -> Progress step fail ()+stepProgress step = Step step (Done ())++-- | Fail the computation.+failProgress :: fail -> Progress step fail done+failProgress err = Fail err++-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two+-- base cases, one for a final result and one for failure.+--+-- 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 err done = fold+  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++instance Applicative (Progress step fail) where+  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+  p <|> q = foldProgress Step (const q) Done p
+ src/Distribution/Utils/UnionFind.hs view
@@ -0,0 +1,104 @@+{-# 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++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)++-- | Mutable write to a 'Point'+writePoint :: Point s a -> Link s a -> ST s ()+writePoint (Point v) = writeSTRef v++-- | Read the current value of 'Point'.+readPoint :: Point s a -> ST s (Link s a)+readPoint (Point v) = readSTRef v++-- | The internal data structure for a 'Point', which either records+-- 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)++-- | 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)++-- | 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+        point'' <- repr point'+        when (point'' /= point') $ do+          writePoint point =<< readPoint point'+        return point''+      Info _ _ -> return point++-- | Return the canonical element of an equivalence+-- class 'Point'.+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' ->+          case r' of+            Info _ d_ref -> readSTRef d_ref+            Link _ -> repr point >>= find++-- | Unify two equivalence classes, so that they share+-- a canonical element. Keeps the descriptor of point2.+union :: Point s a -> Point s a -> ST s ()+union refpoint1 refpoint2 = 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"++-- | Test if two points are in the same equivalence class.+equivalent :: Point s a -> Point s a -> ST s Bool+equivalent point1 point2 = liftM2 (==) (repr point1) (repr point2)
+ src/Distribution/Verbosity.hs view
@@ -0,0 +1,377 @@+{-# LANGUAGE DeriveGeneric #-}++-----------------------------------------------------------------------------++-- Verbosity for Cabal functions.++-- |+-- Module      :  Distribution.Verbosity+-- Copyright   :  Ian Lynagh 2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- A 'Verbosity' type with associated utilities.+--+-- There are 4 standard verbosity levels from 'silent', 'normal',+-- 'verbose' up to 'deafening'. This is used for deciding what logging+-- messages to print.+--+-- Verbosity also is equipped with some internal settings which can be+-- used to control at a fine granularity the verbosity of specific+-- 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.+module Distribution.Verbosity+  ( -- * Verbosity+    Verbosity+  , silent+  , normal+  , verbose+  , deafening+  , moreVerbose+  , lessVerbose+  , isVerboseQuiet+  , intToVerbosity+  , flagToVerbosity+  , showForCabal+  , showForGHC+  , verboseNoFlags+  , verboseHasFlags+  , modifyVerbosity++    -- * Call stacks+  , verboseCallSite+  , verboseCallStack+  , isVerboseCallSite+  , isVerboseCallStack++    -- * Output markets+  , verboseMarkOutput+  , isVerboseMarkOutput+  , verboseUnmarkOutput++    -- * Line wrapping+  , verboseNoWrap+  , isVerboseNoWrap++    -- * Time stamps+  , verboseTimestamp+  , isVerboseTimestamp+  , verboseNoTimestamp++    -- * Stderr+  , verboseStderr+  , isVerboseStderr+  , verboseNoStderr++    -- * No warnings+  , verboseNoWarn+  , isVerboseNoWarn+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.ReadE++import Data.List (elemIndex)+import Distribution.Parsec+import Distribution.Pretty+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)++mkVerbosity :: VerbosityLevel -> Verbosity+mkVerbosity l = Verbosity{vLevel = l, vFlags = Set.empty, vQuiet = False}++instance Eq Verbosity where+  x == y = vLevel x == vLevel y++instance Ord Verbosity where+  compare x y = compare (vLevel x) (vLevel y)++instance Enum Verbosity where+  toEnum = mkVerbosity . toEnum+  fromEnum = fromEnum . vLevel++instance Bounded Verbosity where+  minBound = mkVerbosity minBound+  maxBound = mkVerbosity maxBound++instance Binary Verbosity+instance Structured Verbosity++-- | 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.+normal :: Verbosity+normal = mkVerbosity Normal++-- | 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.+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++-- | Decrease verbosity level, but stay 'deafening' if we are.+lessVerbose :: Verbosity -> Verbosity+lessVerbose v =+  verboseQuiet $+    case vLevel v of+      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.+--+-- For instance, the following property holds+--+-- prop> isVerboseNoWrap (modifyVerbosity (max verbose) v) == isVerboseNoWrap v+--+-- __Note__: you can use @modifyVerbosity (const v1) v0@ to overwrite+-- @v1@'s flags with @v0@'s flags.+--+-- @since 2.0.1.0+modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity+modifyVerbosity f v = v{vLevel = vLevel (f v)}++-- | Numeric verbosity level @0..3@: @0@ is 'silent', @3@ is 'deafening'.+intToVerbosity :: Int -> Maybe Verbosity+intToVerbosity 0 = Just (mkVerbosity Silent)+intToVerbosity 1 = Just (mkVerbosity Normal)+intToVerbosity 2 = Just (mkVerbosity Verbose)+intToVerbosity 3 = Just (mkVerbosity Deafening)+intToVerbosity _ = Nothing++-- | Parser verbosity+--+-- >>> explicitEitherParsec parsecVerbosity "normal"+-- Right (Verbosity {vLevel = Normal, vFlags = fromList [], vQuiet = False})+--+-- >>> explicitEitherParsec parsecVerbosity "normal+nowrap  "+-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap], vQuiet = False})+--+-- >>> explicitEitherParsec parsecVerbosity "normal+nowrap +markoutput"+-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False})+--+-- >>> explicitEitherParsec parsecVerbosity "normal +nowrap +markoutput"+-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False})+--+-- >>> explicitEitherParsec parsecVerbosity "normal+nowrap+markoutput"+-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False})+--+-- >>> explicitEitherParsec parsecVerbosity "deafening+nowrap+stdout+stderr+callsite+callstack"+-- Right (Verbosity {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False})+--+-- /Note:/ this parser will eat trailing spaces.+instance Parsec Verbosity where+  parsec = parsecVerbosity++instance Pretty Verbosity where+  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"++    parseStringVerbosity = do+      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+    parseFlag = do+      _ <- P.char '+'+      token <- P.munch1 isAsciiAlpha+      case token of+        "callsite" -> return verboseCallSite+        "callstack" -> return verboseCallStack+        "nowrap" -> return verboseNoWrap+        "markoutput" -> return verboseMarkOutput+        "timestamp" -> return verboseTimestamp+        "stderr" -> return verboseStderr+        "stdout" -> return verboseNoStderr+        "nowarn" -> return verboseNoWarn+        _ -> P.unexpected $ "Bad verbosity flag: " ++ token++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))+  where+    showLevel Silent = "silent"+    showLevel Normal = "normal"+    showLevel Verbose = "verbose"+    showLevel Deafening = "debug"++    showFlag VCallSite = ["+callsite"]+    showFlag VCallStack = ["+callstack"]+    showFlag VNoWrap = ["+nowrap"]+    showFlag VMarkOutput = ["+markoutput"]+    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++-- | Turn on verbose call-site printing when we log.+verboseCallSite :: Verbosity -> Verbosity+verboseCallSite = verboseFlag VCallSite++-- | Turn on verbose call-stack printing when we log.+verboseCallStack :: Verbosity -> Verbosity+verboseCallStack = verboseFlag VCallStack++-- | Turn on @-----BEGIN CABAL OUTPUT-----@ markers for output+-- from Cabal (as opposed to GHC, or system dependent).+verboseMarkOutput :: Verbosity -> Verbosity+verboseMarkOutput = verboseFlag VMarkOutput++-- | Turn off marking; useful for suppressing nondeterministic output.+verboseUnmarkOutput :: Verbosity -> Verbosity+verboseUnmarkOutput = verboseNoFlag VMarkOutput++-- | Disable line-wrapping for log messages.+verboseNoWrap :: Verbosity -> Verbosity+verboseNoWrap = verboseFlag VNoWrap++-- | Mark the verbosity as quiet.+verboseQuiet :: Verbosity -> Verbosity+verboseQuiet v = v{vQuiet = True}++-- | Turn on timestamps for log messages.+verboseTimestamp :: Verbosity -> Verbosity+verboseTimestamp = verboseFlag VTimestamp++-- | Turn off timestamps for log messages.+verboseNoTimestamp :: Verbosity -> Verbosity+verboseNoTimestamp = verboseNoFlag VTimestamp++-- | Switch logging to 'stderr'.+--+-- @since 3.4.0.0+verboseStderr :: Verbosity -> Verbosity+verboseStderr = verboseFlag VStderr++-- | Switch logging to 'stdout'.+--+-- @since 3.4.0.0+verboseNoStderr :: Verbosity -> Verbosity+verboseNoStderr = verboseNoFlag VStderr++-- | 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)}++-- | Helper function for flag disabling functions.+verboseNoFlag :: VerbosityFlag -> (Verbosity -> Verbosity)+verboseNoFlag flag v = v{vFlags = Set.delete flag (vFlags v)}++-- | Turn off all flags.+verboseNoFlags :: Verbosity -> Verbosity+verboseNoFlags v = v{vFlags = Set.empty}++verboseHasFlags :: Verbosity -> Bool+verboseHasFlags = not . Set.null . vFlags++-- | Test if we should output call sites when we log.+isVerboseCallSite :: Verbosity -> Bool+isVerboseCallSite = isVerboseFlag VCallSite++-- | Test if we should output call stacks when we log.+isVerboseCallStack :: Verbosity -> Bool+isVerboseCallStack = isVerboseFlag VCallStack++-- | Test if we should output markets.+isVerboseMarkOutput :: Verbosity -> Bool+isVerboseMarkOutput = isVerboseFlag VMarkOutput++-- | Test if line-wrapping is disabled for log messages.+isVerboseNoWrap :: Verbosity -> Bool+isVerboseNoWrap = isVerboseFlag VNoWrap++-- | Test if we had called 'lessVerbose' on the verbosity.+isVerboseQuiet :: Verbosity -> Bool+isVerboseQuiet = vQuiet++-- | Test if we should output timestamps when we log.+isVerboseTimestamp :: Verbosity -> Bool+isVerboseTimestamp = isVerboseFlag VTimestamp++-- | 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+isVerboseFlag flag = (Set.member flag) . vFlags++-- $setup+-- >>> import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum)+-- >>> instance Arbitrary VerbosityLevel where arbitrary = arbitraryBoundedEnum+-- >>> instance Arbitrary Verbosity where arbitrary = fmap mkVerbosity arbitrary
+ src/Distribution/Verbosity/Internal.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Verbosity.Internal+  ( VerbosityLevel (..)+  , VerbosityFlag (..)+  ) where++import Distribution.Compat.Prelude+import Prelude ()++data VerbosityLevel = Silent | Normal | Verbose | Deafening+  deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)++instance Binary VerbosityLevel+instance Structured VerbosityLevel++data VerbosityFlag+  = 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/ZinzaPrelude.hs view
@@ -0,0 +1,44 @@+-- | A small prelude used in @zinza@ generated+-- template modules.+module Distribution.ZinzaPrelude+  ( Writer+  , execWriter+  , tell++    -- * Re-exports+  , forM_+  , Generic+  , PackageName+  , Version+  , prettyShow+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Control.Monad (forM_)+import Distribution.Pretty (prettyShow)+import Distribution.Types.PackageName (PackageName)+import Distribution.Types.Version (Version)++newtype Writer a = W {unW :: ShowS -> (ShowS, a)}++instance Functor Writer where+  fmap = liftM++instance Applicative Writer where+  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 (>>=) #-}++execWriter :: Writer a -> String+execWriter w = fst (unW w id) ""++tell :: String -> Writer ()+tell s = W $ \s' -> (s' . showString s, ())
− tests/PackageTests/BenchmarkStanza/Check.hs 
@@ -1,57 +0,0 @@-module PackageTests.BenchmarkStanza.Check where--import Test.HUnit-import System.FilePath-import PackageTests.PackageTester-import Data.List (isInfixOf, intercalate)-import Distribution.Version-import Distribution.PackageDescription.Parse-        ( readPackageDescription )-import Distribution.PackageDescription.Configuration-        ( finalizePackageDescription )-import Distribution.Package-        ( PackageIdentifier(..), PackageName(..), Dependency(..) )-import Distribution.PackageDescription-        ( PackageDescription(..), BuildInfo(..), Benchmark(..), Library(..)-        , BenchmarkInterface(..)-        , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary-        , emptyBenchmark, BuildType(..) )-import Distribution.Verbosity (silent)-import Distribution.License (License(..))-import Distribution.ModuleName (fromString)-import Distribution.System (buildPlatform)-import Distribution.Compiler-        ( CompilerId(..), CompilerFlavor(..) )-import Distribution.Text--suite :: Version -> Test-suite cabalVersion = TestCase $ do-    let directory = "PackageTests" </> "BenchmarkStanza"-        pdFile = directory </> "my" <.> "cabal"-        spec = PackageSpec directory []-    result <- cabal_configure spec-    let message = "cabal configure should recognize benchmark section"-        test = "unknown section type"-               `isInfixOf`-               (intercalate " " $ lines $ outputText result)-    assertEqual message False test-    genPD <- readPackageDescription silent pdFile-    let compiler = CompilerId GHC $ Version [6, 12, 2] []-        anyV = intersectVersionRanges anyVersion anyVersion-        anticipatedBenchmark = emptyBenchmark-            { benchmarkName = "dummy"-            , benchmarkInterface = BenchmarkExeV10 (Version [1,0] []) "dummy.hs"-            , benchmarkBuildInfo = emptyBuildInfo-                    { targetBuildDepends =-                            [ Dependency (PackageName "base") anyVersion ]-                    , hsSourceDirs = ["."]-                    }-            , benchmarkEnabled = False-            }-    case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of-        Left xs -> let depMessage = "should not have missing dependencies:\n" ++-                                    (unlines $ map (show . disp) xs)-                   in assertEqual depMessage True False-        Right (f, _) -> let gotBenchmark = head $ benchmarks f-                        in assertEqual "parsed benchmark stanza does not match anticipated"-                                gotBenchmark anticipatedBenchmark
− tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs 
@@ -1,15 +0,0 @@-module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import Data.List---suite :: Test-suite = TestCase $ do-    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "GlobalBuildDepsNotAdditive1") []-    result <- cabal_build spec-    assertEqual "cabal build should fail - see test-log.txt" False (successful result)-    assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $-        "Failed to load interface for `Prelude'" `isInfixOf` outputText result
− tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs 
@@ -1,15 +0,0 @@-module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import Data.List---suite :: Test-suite = TestCase $ do-    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "GlobalBuildDepsNotAdditive2") []-    result <- cabal_build spec-    assertEqual "cabal build should fail - see test-log.txt" False (successful result)-    assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $-        "Failed to load interface for `Prelude'" `isInfixOf` outputText result
− tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs 
@@ -1,20 +0,0 @@-module PackageTests.BuildDeps.InternalLibrary0.Check where--import Test.HUnit-import PackageTests.PackageTester-import Control.Monad-import System.FilePath-import Data.Version-import Data.List (isInfixOf, intercalate)---suite :: Version -> Test-suite cabalVersion = TestCase $ do-    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary0") []-    result <- cabal_build spec-    assertEqual "cabal build should fail" False (successful result)-    when (cabalVersion >= Version [1, 7] []) $ do-        -- In 1.7 it should tell you how to enable the desired behaviour.-        assertEqual "error should say 'library which is defined within the same package.'" True $-            "library which is defined within the same package." `isInfixOf` (intercalate " " $ lines $ outputText result)-
− tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs 
@@ -1,12 +0,0 @@-module PackageTests.BuildDeps.InternalLibrary1.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath---suite :: Test-suite = TestCase $ do-    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary1") []-    result <- cabal_build spec-    assertEqual "cabal build should succeed - see test-log.txt" True (successful result)
− tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs 
@@ -1,24 +0,0 @@-module PackageTests.BuildDeps.InternalLibrary2.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import qualified Data.ByteString.Char8 as C---suite :: Test-suite = TestCase $ do-    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary2") []-    let specTI = PackageSpec (directory spec </> "to-install") []--    unregister "InternalLibrary2"-    iResult <- cabal_install specTI                     -    assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult)-    bResult <- cabal_build spec-    assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult)-    unregister "InternalLibrary2"--    (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" []-    C.appendFile (directory spec </> "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output)-    assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output)-
− tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs 
@@ -1,24 +0,0 @@-module PackageTests.BuildDeps.InternalLibrary3.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import qualified Data.ByteString.Char8 as C---suite :: Test-suite = TestCase $ do-    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary3") []-    let specTI = PackageSpec (directory spec </> "to-install") []--    unregister "InternalLibrary3"-    iResult <- cabal_install specTI                     -    assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult)-    bResult <- cabal_build spec-    assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult)-    unregister "InternalLibrary3"--    (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" []-    C.appendFile (directory spec </> "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output)-    assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output)-
− tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs 
@@ -1,24 +0,0 @@-module PackageTests.BuildDeps.InternalLibrary4.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import qualified Data.ByteString.Char8 as C---suite :: Test-suite = TestCase $ do-    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary4") []-    let specTI = PackageSpec (directory spec </> "to-install") []--    unregister "InternalLibrary4"-    iResult <- cabal_install specTI                     -    assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult)-    bResult <- cabal_build spec-    assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult)-    unregister "InternalLibrary4"--    (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" []-    C.appendFile (directory spec </> "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output)-    assertEqual "executable should have linked with the installed library" "myLibFunc installed" (concat $ lines output)-
− tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs 
@@ -1,12 +0,0 @@-module PackageTests.BuildDeps.SameDepsAllRound.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath---suite :: Test-suite = TestCase $ do-    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "SameDepsAllRound") []-    result <- cabal_build spec-    assertEqual "cabal build should succeed - see test-log.txt" True (successful result)
− tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs 
@@ -1,18 +0,0 @@-module PackageTests.BuildDeps.TargetSpecificDeps1.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import Data.List---suite :: Test-suite = TestCase $ do-    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps1") []-    result <- cabal_build spec-    assertEqual "cabal build should fail - see test-log.txt" False (successful result)-    assertBool "error should be in MyLibrary.hs" $-        "MyLibrary.hs:" `isInfixOf` outputText result-    assertBool "error should be \"Could not find module `System.Time\"" $-        "Could not find module `System.Time'" `isInfixOf`-                        (intercalate " " $ lines $ outputText result)
− tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs 
@@ -1,13 +0,0 @@-module PackageTests.BuildDeps.TargetSpecificDeps2.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import Data.List---suite :: Test-suite = TestCase $ do-    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps2") []-    result <- cabal_build spec-    assertEqual "cabal build should succeed - see test-log.txt" True (successful result)
− tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs 
@@ -1,17 +0,0 @@-module PackageTests.BuildDeps.TargetSpecificDeps3.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import Data.List---suite :: Test-suite = TestCase $ do-    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps3") []-    result <- cabal_build spec-    assertEqual "cabal build should fail - see test-log.txt" False (successful result)-    assertBool "error should be in lemon.hs" $-        "lemon.hs:" `isInfixOf` outputText result-    assertBool "error should be \"Could not find module `System.Time\"" $-        "Could not find module `System.Time'" `isInfixOf` (intercalate " " $ lines $ outputText result)
− tests/PackageTests/PackageTester.hs 
@@ -1,206 +0,0 @@-module PackageTests.PackageTester (-        PackageSpec(..),-        Success(..),-        Result(..),-        cabal_configure,-        cabal_build,-        cabal_test,-        cabal_bench,-        cabal_install,-        unregister,-        run-    ) where--import qualified Control.Exception.Extensible as E-import System.Directory-import System.FilePath-import System.IO-import System.Posix.IO-import System.Process-import System.Exit-import Control.Concurrent.Chan-import Control.Concurrent.MVar-import Control.Concurrent-import Control.Monad-import Data.List-import Data.Maybe-import qualified Data.ByteString.Char8 as C---data PackageSpec =-    PackageSpec {-        directory  :: FilePath,-        configOpts :: [String]-    }--data Success = Failure-             | ConfigureSuccess-             | BuildSuccess-             | InstallSuccess-             | TestSuccess-             | BenchSuccess-             deriving (Eq, Show)--data Result = Result {-        successful :: Bool,-        success    :: Success,-        outputText :: String-    }-    deriving Show--nullResult :: Result-nullResult = Result True Failure ""--recordRun :: (String, ExitCode, String) -> Success -> Result -> Result-recordRun (cmd, exitCode, exeOutput) thisSucc res =-    res {-        successful = successful res && exitCode == ExitSuccess,-        success = if exitCode == ExitSuccess then thisSucc-                                             else success res,-        outputText =-            (if null $ outputText res then "" else outputText res ++ "\n") ++-                cmd ++ "\n" ++ exeOutput-    }--cabal_configure :: PackageSpec -> IO Result-cabal_configure spec = do-    res <- doCabalConfigure spec-    record spec res-    return res--doCabalConfigure :: PackageSpec -> IO Result-doCabalConfigure spec = do-    cleanResult@(_, _, cleanOutput) <- cabal spec ["clean"]-    requireSuccess cleanResult-    res <- cabal spec $ ["configure", "--user"] ++ configOpts spec-    return $ recordRun res ConfigureSuccess nullResult--doCabalBuild :: PackageSpec -> IO Result-doCabalBuild spec = do-    configResult <- doCabalConfigure spec-    if successful configResult-        then do-            res <- cabal spec ["build"]-            return $ recordRun res BuildSuccess configResult-        else-            return configResult--cabal_build :: PackageSpec -> IO Result-cabal_build spec = do-    res <- doCabalBuild spec-    record spec res-    return res--unregister :: String -> IO ()-unregister libraryName = do-    res@(_, _, output) <- run Nothing "ghc-pkg" ["unregister", "--user", libraryName]-    if "cannot find package" `isInfixOf` output-        then return ()-        else requireSuccess res---- | Install this library in the user area-cabal_install :: PackageSpec -> IO Result-cabal_install spec = do-    buildResult <- doCabalBuild spec-    res <- if successful buildResult-        then do-            res <- cabal spec ["install"]-            return $ recordRun res InstallSuccess buildResult-        else-            return buildResult-    record spec res-    return res--cabal_test :: PackageSpec -> [String] -> IO Result-cabal_test spec extraArgs = do-    res <- cabal spec $ "test" : extraArgs-    let r = recordRun res TestSuccess nullResult-    record spec r-    return r--cabal_bench :: PackageSpec -> [String] -> IO Result-cabal_bench spec extraArgs = do-    res <- cabal spec $ "bench" : extraArgs-    let r = recordRun res BenchSuccess nullResult-    record spec r-    return r---- | Returns the command that was issued, the return code, and hte output text-cabal :: PackageSpec -> [String] -> IO (String, ExitCode, String)-cabal spec cabalArgs = do-    wd <- getCurrentDirectory-    r <- run (Just $ directory spec) "ghc"-             [ "--make"-             , "-fhpc"-             , "-package-conf " ++ wd </> "../dist/package.conf.inplace"-             , "Setup.hs"-             ]-    requireSuccess r-    run (Just $ directory spec) (wd </> directory spec </> "Setup") cabalArgs---- | Returns the command that was issued, the return code, and hte output text-run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String)-run cwd cmd args = do-    -- Posix-specific-    (outf, outf0) <- createPipe-    (errf, errf0) <- createPipe-    outh <- fdToHandle outf-    outh0 <- fdToHandle outf0-    errh <- fdToHandle errf-    errh0 <- fdToHandle errf0-    pid <- runProcess cmd args cwd Nothing Nothing (Just outh0) (Just errh0)--    {--    -- ghc-6.10.1 specific-    (Just inh, Just outh, Just errh, pid) <--        createProcess (proc cmd args){ std_in  = CreatePipe,-                                       std_out = CreatePipe,-                                       std_err = CreatePipe,-                                       cwd     = cwd }-    hClose inh -- done with stdin-    -}--    -- fork off a thread to start consuming the output-    outChan <- newChan-    forkIO $ suckH outChan outh-    forkIO $ suckH outChan errh--    output <- suckChan outChan--    hClose outh-    hClose errh--    -- wait on the process-    ex <- waitForProcess pid-    let fullCmd = intercalate " " $ cmd:args-    return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd,-        ex, output)-  where-    suckH chan h = do-        eof <- hIsEOF h-        if eof-            then writeChan chan Nothing-            else do-                c <- hGetChar h-                writeChan chan $ Just c-                suckH chan h-    suckChan chan = sc' chan 2 []-      where-        sc' _ 0 acc = return $ reverse acc-        sc' chan eofs acc = do-            mC <- readChan chan-            case mC of-                Just c -> sc' chan eofs (c:acc)-                Nothing -> sc' chan (eofs-1) acc--requireSuccess :: (String, ExitCode, String) -> IO ()-requireSuccess (cmd, exitCode, output) = do-    case exitCode of-        ExitSuccess -> return ()-        ExitFailure r -> do-            ioError $ userError $ "Command " ++ cmd ++ " failed."--record :: PackageSpec -> Result -> IO ()-record spec res = do-    C.writeFile (directory spec </> "test-log.txt") (C.pack $ outputText res)-
− tests/PackageTests/TestOptions/Check.hs 
@@ -1,23 +0,0 @@-module PackageTests.TestOptions.Check where--import Test.HUnit-import System.FilePath-import PackageTests.PackageTester--suite :: Test-suite = TestCase $ do-    let directory = "PackageTests" </> "TestOptions"-        pdFile = directory </> "TestOptions" <.> "cabal"-        spec = PackageSpec directory ["--enable-tests"]-    _ <- cabal_build spec-    result <- cabal_test spec ["--test-options=1 2 3"]-    let message = "\"cabal test\" did not pass the correct options to the "-                  ++ "test executable with \"--test-options\""-    assertEqual message True $ successful result-    result' <- cabal_test spec [ "--test-option=1"-                               , "--test-option=2"-                               , "--test-option=3"-                               ]-    let message = "\"cabal test\" did not pass the correct options to the "-                  ++ "test executable with \"--test-option\""-    assertEqual message True $ successful result'
− tests/PackageTests/TestStanza/Check.hs 
@@ -1,57 +0,0 @@-module PackageTests.TestStanza.Check where--import Test.HUnit-import System.FilePath-import PackageTests.PackageTester-import Data.List (isInfixOf, intercalate)-import Distribution.Version-import Distribution.PackageDescription.Parse-        ( readPackageDescription )-import Distribution.PackageDescription.Configuration-        ( finalizePackageDescription )-import Distribution.Package-        ( PackageIdentifier(..), PackageName(..), Dependency(..) )-import Distribution.PackageDescription-        ( PackageDescription(..), BuildInfo(..), TestSuite(..), Library(..)-        , TestSuiteInterface(..)-        , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary-        , emptyTestSuite, BuildType(..) )-import Distribution.Verbosity (silent)-import Distribution.License (License(..))-import Distribution.ModuleName (fromString)-import Distribution.System (buildPlatform)-import Distribution.Compiler-        ( CompilerId(..), CompilerFlavor(..) )-import Distribution.Text--suite :: Version -> Test-suite cabalVersion = TestCase $ do-    let directory = "PackageTests" </> "TestStanza"-        pdFile = directory </> "my" <.> "cabal"-        spec = PackageSpec directory []-    result <- cabal_configure spec-    let message = "cabal configure should recognize test section"-        test = "unknown section type"-               `isInfixOf`-               (intercalate " " $ lines $ outputText result)-    assertEqual message False test-    genPD <- readPackageDescription silent pdFile-    let compiler = CompilerId GHC $ Version [6, 12, 2] []-        anyV = intersectVersionRanges anyVersion anyVersion-        anticipatedTestSuite = emptyTestSuite-            { testName = "dummy"-            , testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs"-            , testBuildInfo = emptyBuildInfo-                    { targetBuildDepends =-                            [ Dependency (PackageName "base") anyVersion ]-                    , hsSourceDirs = ["."]-                    }-            , testEnabled = False-            }-    case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of-        Left xs -> let depMessage = "should not have missing dependencies:\n" ++-                                    (unlines $ map (show . disp) xs)-                   in assertEqual depMessage True False-        Right (f, _) -> let gotTest = head $ testSuites f-                        in assertEqual "parsed test-suite stanza does not match anticipated"-                                gotTest anticipatedTestSuite
− tests/PackageTests/TestSuiteExeV10/Check.hs 
@@ -1,47 +0,0 @@-module PackageTests.TestSuiteExeV10.Check-       ( checkTest-       , checkTestWithHpc-       ) where--import Distribution.PackageDescription ( TestSuite(..), emptyTestSuite )-import Distribution.Simple.Hpc-import Distribution.Version-import Test.HUnit-import System.Directory-import System.FilePath-import PackageTests.PackageTester--dir :: FilePath-dir = "PackageTests" </> "TestSuiteExeV10"--checkTest :: Version -> Test-checkTest cabalVersion = TestCase $ do-    let spec = PackageSpec dir ["--enable-tests"]-    buildResult <- cabal_build spec-    let buildMessage = "\'setup build\' should succeed"-    assertEqual buildMessage True $ successful buildResult-    testResult <- cabal_test spec []-    let testMessage = "\'setup test\' should succeed"-    assertEqual testMessage True $ successful testResult--checkTestWithHpc :: Version -> Test-checkTestWithHpc cabalVersion = TestCase $ do-    let spec = PackageSpec dir [ "--enable-tests"-                               , "--enable-library-coverage"-                               ]-    buildResult <- cabal_build spec-    let buildMessage = "\'setup build\' should succeed"-    assertEqual buildMessage True $ successful buildResult-    testResult <- cabal_test spec []-    let testMessage = "\'setup test\' should succeed"-    assertEqual testMessage True $ successful testResult-    let dummy = emptyTestSuite { testName = "test-Foo" }-        tixFile = tixFilePath (dir </> "dist") $ testName dummy-        tixFileMessage = ".tix file should exist"-        markupDir = htmlDir (dir </> "dist") $ testName dummy-        markupFile = markupDir </> "hpc_index" <.> "html"-        markupFileMessage = "HPC markup file should exist"-    tixFileExists <- doesFileExist tixFile-    assertEqual tixFileMessage True tixFileExists-    markupFileExists <- doesFileExist markupFile-    assertEqual markupFileMessage True markupFileExists
− tests/suite.hs 
@@ -1,77 +0,0 @@--- The intention is that this will be the new unit test framework.--- Please add any working tests here.  This file should do nothing--- but import tests from other modules.------ Stephen Blackheath, 2009--module Main where--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import qualified Test.HUnit as HUnit-import PackageTests.BenchmarkExeV10.Check-import PackageTests.BenchmarkOptions.Check-import PackageTests.BenchmarkStanza.Check-import PackageTests.BuildDeps.SameDepsAllRound.Check-import PackageTests.BuildDeps.TargetSpecificDeps1.Check-import PackageTests.BuildDeps.TargetSpecificDeps1.Check-import PackageTests.BuildDeps.TargetSpecificDeps2.Check-import PackageTests.BuildDeps.TargetSpecificDeps3.Check-import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check-import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check-import PackageTests.BuildDeps.InternalLibrary0.Check-import PackageTests.BuildDeps.InternalLibrary1.Check-import PackageTests.BuildDeps.InternalLibrary2.Check-import PackageTests.BuildDeps.InternalLibrary3.Check-import PackageTests.BuildDeps.InternalLibrary4.Check-import PackageTests.TestOptions.Check-import PackageTests.TestStanza.Check-import PackageTests.TestSuiteExeV10.Check-import Distribution.Text (display)-import Distribution.Simple.Utils (cabalVersion)-import Data.Version-import System.Directory--hunit :: TestName -> HUnit.Test -> Test-hunit name test = testGroup name $ hUnitTestToTests test--tests :: Version -> [Test]-tests cabalVersion = [-        hunit "PackageTests/BuildDeps/SameDepsAllRound/" PackageTests.BuildDeps.SameDepsAllRound.Check.suite,-        hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite,-        hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite,-        hunit "PackageTests/BuildDeps/InternalLibrary0/" (PackageTests.BuildDeps.InternalLibrary0.Check.suite cabalVersion),-        hunit "PackageTests/TestStanza/" (PackageTests.TestStanza.Check.suite cabalVersion),-        -- ^ The Test stanza test will eventually be required-        -- only for higher versions.-        hunit "PackageTests/TestSuiteExeV10/Test"-        (PackageTests.TestSuiteExeV10.Check.checkTest cabalVersion),-        hunit "PackageTests/TestSuiteExeV10/TestWithHpc"-        (PackageTests.TestSuiteExeV10.Check.checkTestWithHpc cabalVersion),-        hunit "PackageTests/TestOptions" PackageTests.TestOptions.Check.suite,-        hunit "PackageTests/BenchmarkStanza/" (PackageTests.BenchmarkStanza.Check.suite cabalVersion),-        -- ^ The benchmark stanza test will eventually be required-        -- only for higher versions.-        hunit "PackageTests/BenchmarkExeV10/Test"-        (PackageTests.BenchmarkExeV10.Check.checkBenchmark cabalVersion),-        hunit "PackageTests/BenchmarkOptions" PackageTests.BenchmarkOptions.Check.suite-    ] ++-    -- These tests are only required to pass on cabal version >= 1.7-    (if cabalVersion >= Version [1, 7] []-        then [-            hunit "PackageTests/BuildDeps/TargetSpecificDeps1/" PackageTests.BuildDeps.TargetSpecificDeps1.Check.suite,-            hunit "PackageTests/BuildDeps/TargetSpecificDeps2/" PackageTests.BuildDeps.TargetSpecificDeps2.Check.suite,-            hunit "PackageTests/BuildDeps/TargetSpecificDeps3/" PackageTests.BuildDeps.TargetSpecificDeps3.Check.suite,-            hunit "PackageTests/BuildDeps/InternalLibrary1/" PackageTests.BuildDeps.InternalLibrary1.Check.suite,-            hunit "PackageTests/BuildDeps/InternalLibrary2/" PackageTests.BuildDeps.InternalLibrary2.Check.suite,-            hunit "PackageTests/BuildDeps/InternalLibrary3/" PackageTests.BuildDeps.InternalLibrary3.Check.suite,-            hunit "PackageTests/BuildDeps/InternalLibrary4/" PackageTests.BuildDeps.InternalLibrary4.Check.suite-        ]-        else [])--main = do-    putStrLn $ "Cabal test suite - testing cabal version "++display cabalVersion-    setCurrentDirectory "tests"-    defaultMain (tests cabalVersion)-